diff options
46 files changed, 4587 insertions, 2500 deletions
diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index f2823c90c8..f0403a7318 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -8,8 +8,11 @@ stages: - stage-4 # Only dependencies in stage 1, 2 and 3 - deploy -# When a job has no dependencies, it goes to stage 1. -# Otherwise, we set "needs" and "dependencies" to the same value. +# When a job has no dependencies, it goes to stage 1. Otherwise, we +# set both "needs" and "dependencies". "needs" is a superset of +# "dependencies" that should include all the transitive dependencies. +# "dependencies" only list the previous jobs whose artifact we need to +# keep. # some default values variables: @@ -376,6 +379,9 @@ pkg:nix:deploy:channel: name: cachix url: https://coq.cachix.org only: + refs: # Repeat conditions from pkg:nix:deploy + - master + - /^v.*\..*$/ variables: - $CACHIX_DEPLOYMENT_KEY dependencies: [] @@ -598,6 +604,7 @@ library:ci-corn: stage: stage-4 needs: - build:edge+flambda + - plugin:ci-bignums - library:ci-math-classes dependencies: - build:edge+flambda @@ -631,6 +638,7 @@ library:ci-math-comp: library:ci-sf: extends: .ci-template + allow_failure: true # Waiting for integration of the fix for #10476 library:ci-stdlib2: extends: .ci-template-flambda diff --git a/dev/doc/critical-bugs b/dev/doc/critical-bugs index d00c8cb11a..78d7061259 100644 --- a/dev/doc/critical-bugs +++ b/dev/doc/critical-bugs @@ -129,6 +129,18 @@ Universes GH issue number: #9294 risk: moderate risk to be activated by chance + component: universe polymorphism, asynchronous proofs + summary: universe constraints erroneously discarded when forcing an asynchronous proof containing delayed monomorphic constraints inside a universe polymorphic section + introduced: between 8.4 and 8.5 by merging the asynchronous proofs feature branch and universe polymorphism one + impacted released: V8.5-V8.10 + impacted development branches: none + impacted coqchk versions: immune + fixed in: PR#10664 + found by: Pédrot + exploit: no test + GH issue number: none + risk: unlikely to be triggered in interactive mode, not present in batch mode (i.e. coqc) + Primitive projections component: primitive projections, guard condition diff --git a/doc/changelog/01-kernel/10664-sections-stack-in-kernel.rst b/doc/changelog/01-kernel/10664-sections-stack-in-kernel.rst new file mode 100644 index 0000000000..bac08d12ea --- /dev/null +++ b/doc/changelog/01-kernel/10664-sections-stack-in-kernel.rst @@ -0,0 +1,6 @@ +- Section data is now part of the kernel. Solves a soundness issue + in interactive mode where global monomorphic universe constraints would be + dropped when forcing a delayed opaque proof inside a polymorphic section. Also + relaxes the nesting criterion for sections, as polymorphic sections can now + appear inside a monomorphic one + (#10664, <https://github.com/coq/coq/pull/10664> by Pierre-Marie Pédrot). diff --git a/doc/changelog/02-specification-language/10758-fix-10757.rst b/doc/changelog/02-specification-language/10758-fix-10757.rst new file mode 100644 index 0000000000..4cce26aedc --- /dev/null +++ b/doc/changelog/02-specification-language/10758-fix-10757.rst @@ -0,0 +1,5 @@ +- ``Program Fixpoint`` now uses ``ex`` and ``sig`` to make telescopes + involving ``Prop`` types (`#10758 + <https://github.com/coq/coq/pull/10758>`_, by Gaëtan Gilbert, fixing + `#10757 <https://github.com/coq/coq/issues/10757>`_ reported by + Xavier Leroy). diff --git a/doc/changelog/04-tactics/10774-zify-Z_to_N.rst b/doc/changelog/04-tactics/10774-zify-Z_to_N.rst new file mode 100644 index 0000000000..ed46cb101e --- /dev/null +++ b/doc/changelog/04-tactics/10774-zify-Z_to_N.rst @@ -0,0 +1,3 @@ +- The :tacn:`zify` tactic is now aware of `Z.to_N`. + (`#10774 <https://github.com/coq/coq/pull/10774>`_ fixes + `#9162 <https://github.com/coq/coq/issues/9162>`_, by Kazuhiko Sakaguchi). diff --git a/doc/sphinx/addendum/universe-polymorphism.rst b/doc/sphinx/addendum/universe-polymorphism.rst index 7e698bfb66..1d0b732e7d 100644 --- a/doc/sphinx/addendum/universe-polymorphism.rst +++ b/doc/sphinx/addendum/universe-polymorphism.rst @@ -147,14 +147,7 @@ Many other commands support the ``Polymorphic`` flag, including: - :cmd:`Section` will locally set the polymorphism flag inside the section. - ``Variables``, ``Context``, ``Universe`` and ``Constraint`` in a section support - polymorphism. This means that the universe variables (and associated - constraints) are discharged polymorphically over definitions that use - them. In other words, two definitions in the section sharing a common - variable will both get parameterized by the universes produced by the - variable declaration. This is in contrast to a “mononorphic” variable - which introduces global universes and constraints, making the two - definitions depend on the *same* global universes associated to the - variable. + polymorphism. See :ref:`universe-polymorphism-in-sections` for more details. - :cmd:`Hint Resolve` and :cmd:`Hint Rewrite` will use the auto/rewrite hint polymorphically, not at a single instance. @@ -375,9 +368,7 @@ to universes and explicitly instantiate polymorphic definitions. as well. Global universe names live in a separate namespace. The command supports the ``Polymorphic`` flag only in sections, meaning the universe quantification will be discharged on each section definition - independently. One cannot mix polymorphic and monomorphic - declarations in the same section. - + independently. .. cmd:: Constraint @universe_constraint Polymorphic Constraint @universe_constraint @@ -510,3 +501,23 @@ underscore or by omitting the annotation to a polymorphic definition. Lemma baz : Type@{outer}. Proof. exact Type@{inner}. Qed. About baz. + +.. _universe-polymorphism-in-sections: + +Universe polymorphism and sections +---------------------------------- + +The universe polymorphic or monomorphic status is +attached to each individual section, and all term or universe declarations +contained inside must respect it, as described below. It is possible to nest a +polymorphic section inside a monomorphic one, but the converse is not allowed. + +:cmd:`Variables`, :cmd:`Context`, :cmd:`Universe` and :cmd:`Constraint` in a section support +polymorphism. This means that the universe variables and their associated +constraints are discharged polymorphically over definitions that use +them. In other words, two definitions in the section sharing a common +variable will both get parameterized by the universes produced by the +variable declaration. This is in contrast to a “mononorphic” variable +which introduces global universes and constraints, making the two +definitions depend on the *same* global universes associated to the +variable. diff --git a/doc/stdlib/index-list.html.template b/doc/stdlib/index-list.html.template index cc91776a4d..d1b98b94a3 100644 --- a/doc/stdlib/index-list.html.template +++ b/doc/stdlib/index-list.html.template @@ -515,7 +515,9 @@ through the <tt>Require Import</tt> command.</p> <dd> theories/Reals/Rdefinitions.v theories/Reals/ConstructiveReals.v + theories/Reals/ConstructiveRealsMorphisms.v theories/Reals/ConstructiveCauchyReals.v + theories/Reals/ConstructiveCauchyRealsMult.v theories/Reals/Raxioms.v theories/Reals/ConstructiveRIneq.v theories/Reals/ConstructiveRealsLUB.v diff --git a/pretyping/inferCumulativity.ml b/kernel/inferCumulativity.ml index ed069eace0..3b8c2cd788 100644 --- a/pretyping/inferCumulativity.ml +++ b/kernel/inferCumulativity.ml @@ -77,7 +77,7 @@ let infer_sort cv_pb variances s = | CUMUL -> LSet.fold infer_level_leq (Universe.levels (Sorts.univ_of_sort s)) variances -let infer_table_key infos variances c = +let infer_table_key variances c = let open Names in match c with | ConstKey (_, u) -> @@ -103,7 +103,7 @@ let rec infer_fterm cv_pb infos variances hd stk = | FRel _ -> infer_stack infos variances stk | FInt _ -> infer_stack infos variances stk | FFlex fl -> - let variances = infer_table_key infos variances fl in + let variances = infer_table_key variances fl in infer_stack infos variances stk | FProj (_,c) -> let variances = infer_fterm CONV infos variances c [] in @@ -152,7 +152,7 @@ and infer_stack infos variances (stk:CClosure.stack) = | Zfix (fx,a) -> let variances = infer_fterm CONV infos variances fx [] in infer_stack infos variances a - | ZcaseT (ci,p,br,e) -> + | ZcaseT (_, p, br, e) -> let variances = infer_fterm CONV infos variances (mk_clos e p) [] in infer_vect infos variances (Array.map (mk_clos e) br) | Zshift _ -> variances @@ -195,7 +195,7 @@ let infer_inductive_core env params entries uctx = Array.fold_left (fun variances u -> LMap.add u IrrelevantI variances) LMap.empty uarray in - let env, params = Typeops.check_context env params in + let env, _ = Typeops.check_context env params in let variances = List.fold_left (fun variances entry -> let variances = infer_arity_constructor true env variances entry.mind_entry_arity @@ -213,9 +213,8 @@ let infer_inductive_core env params entries uctx = let infer_inductive env mie = let open Entries in - let { mind_entry_params = params; - mind_entry_inds = entries; } = mie - in + let params = mie.mind_entry_params in + let entries = mie.mind_entry_inds in let variances = match mie.mind_entry_variance with | None -> None diff --git a/pretyping/inferCumulativity.mli b/kernel/inferCumulativity.mli index a234e334d1..a234e334d1 100644 --- a/pretyping/inferCumulativity.mli +++ b/kernel/inferCumulativity.mli diff --git a/kernel/kernel.mllib b/kernel/kernel.mllib index 59c1d5890f..20e742d7f8 100644 --- a/kernel/kernel.mllib +++ b/kernel/kernel.mllib @@ -43,9 +43,11 @@ Inductive Typeops IndTyping Indtypes +InferCumulativity Cooking Term_typing Subtyping Mod_typing Nativelibrary +Section Safe_typing diff --git a/kernel/opaqueproof.ml b/kernel/opaqueproof.ml index e256466112..f0ffd2e073 100644 --- a/kernel/opaqueproof.ml +++ b/kernel/opaqueproof.ml @@ -142,11 +142,6 @@ let force_constraints _access { opaque_val = prfs; opaque_dir = odp; _ } = funct get_mono (Future.force cu) else Univ.ContextSet.empty -let get_direct_constraints = function -| Indirect _ -> CErrors.anomaly (Pp.str "Not a direct opaque.") -| Direct (_, cu) -> - Future.chain cu get_mono - module FMap = Future.UUIDMap let dump ?(except = Future.UUIDSet.empty) { opaque_val = otab; opaque_len = n; _ } = diff --git a/kernel/opaqueproof.mli b/kernel/opaqueproof.mli index 7c53656c3c..758a9f5107 100644 --- a/kernel/opaqueproof.mli +++ b/kernel/opaqueproof.mli @@ -63,7 +63,6 @@ type indirect_accessor = { indirect opaque accessor given as an argument. *) val force_proof : indirect_accessor -> opaquetab -> opaque -> constr * unit delayed_universes val force_constraints : indirect_accessor -> opaquetab -> opaque -> Univ.ContextSet.t -val get_direct_constraints : opaque -> Univ.ContextSet.t Future.computation val subst_opaque : substitution -> opaque -> opaque diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml index 6970a11e72..db16bd1e79 100644 --- a/kernel/safe_typing.ml +++ b/kernel/safe_typing.ml @@ -113,8 +113,16 @@ type library_info = DirPath.t * vodigest (** Functor and funsig parameters, most recent first *) type module_parameters = (MBId.t * module_type_body) list +(** Part of the safe_env at a section opening time to be backtracked *) +type section_data = { + rev_env : Environ.env; + rev_univ : Univ.ContextSet.t; + rev_objlabels : Label.Set.t; +} + type safe_environment = { env : Environ.env; + sections : section_data Section.t; modpath : ModPath.t; modvariant : modvariant; modresolver : Mod_subst.delta_resolver; @@ -151,6 +159,7 @@ let empty_environment = revstruct = []; modlabels = Label.Set.empty; objlabels = Label.Set.empty; + sections = Section.empty; future_cst = []; univ = Univ.ContextSet.empty; engagement = None; @@ -317,14 +326,25 @@ let universes_of_private eff = let env_of_safe_env senv = senv.env let env_of_senv = env_of_safe_env +let sections_of_safe_env senv = senv.sections + type constraints_addition = | Now of Univ.ContextSet.t | Later of Univ.ContextSet.t Future.computation let push_context_set poly cst senv = - { senv with - env = Environ.push_context_set ~strict:(not poly) cst senv.env; - univ = Univ.ContextSet.union cst senv.univ } + if Univ.ContextSet.is_empty cst then senv + else if Section.is_polymorphic senv.sections then + CErrors.user_err (Pp.str "Cannot add global universe constraints inside a polymorphic section.") + else + let sections = + if Section.is_empty senv.sections then senv.sections + else Section.push_constraints cst senv.sections + in + { senv with + env = Environ.push_context_set ~strict:(not poly) cst senv.env; + univ = Univ.ContextSet.union cst senv.univ; + sections } let add_constraints cst senv = match cst with @@ -386,7 +406,7 @@ let check_current_library dir senv = match senv.modvariant with (** When operating on modules, we're normally outside sections *) let check_empty_context senv = - assert (Environ.empty_context senv.env) + assert (Environ.empty_context senv.env && Section.is_empty senv.sections) (** When adding a parameter to the current module/modtype, it must have been freshly started *) @@ -433,19 +453,30 @@ let safe_push_named d env = with Not_found -> () in Environ.push_named d env - let push_named_def (id,de) senv = + let sections = Section.push_local senv.sections in let c, r, typ = Term_typing.translate_local_def senv.env id de in let x = Context.make_annot id r in let env'' = safe_push_named (LocalDef (x, c, typ)) senv.env in - { senv with env = env'' } + { senv with sections; env = env'' } let push_named_assum (x,t) senv = + let sections = Section.push_local senv.sections in let t, r = Term_typing.translate_local_assum senv.env t in let x = Context.make_annot x r in let env'' = safe_push_named (LocalAssum (x,t)) senv.env in - {senv with env=env''} - + { senv with sections; env = env'' } + +let push_section_context (nas, ctx) senv = + let sections = Section.push_context (nas, ctx) senv.sections in + let senv = { senv with sections } in + let ctx = Univ.ContextSet.of_context ctx in + (* We check that the universes are fresh. FIXME: This should be done + implicitly, but we have to work around the API. *) + let () = assert (Univ.LSet.for_all (fun u -> not (Univ.LSet.mem u (fst senv.univ))) (fst ctx)) in + { senv with + env = Environ.push_context_set ~strict:false ctx senv.env; + univ = Univ.ContextSet.union ctx senv.univ } (** {6 Insertion of new declarations to current environment } *) @@ -527,8 +558,19 @@ let add_field ?(is_include=false) ((l,sfb) as field) gn senv = | SFBmodule mb, M -> Modops.add_module mb senv.env | _ -> assert false in + let sections = match sfb, gn with + | SFBconst cb, C con -> + let poly = Declareops.constant_is_polymorphic cb in + Section.push_constant ~poly con senv.sections + | SFBmind mib, I mind -> + let poly = Declareops.inductive_is_polymorphic mib in + Section.push_inductive ~poly mind senv.sections + | _, (M | MT) -> senv.sections + | _ -> assert false + in { senv with env = env'; + sections; revstruct = field :: senv.revstruct; modlabels = Label.Set.union mlabs senv.modlabels; objlabels = Label.Set.union olabs senv.objlabels } @@ -549,15 +591,6 @@ type exported_private_constant = Constant.t let add_constant_aux ~in_section senv (kn, cb) = let l = Constant.label kn in - let delayed_cst = match cb.const_body with - | OpaqueDef o when not (Declareops.constant_is_polymorphic cb) -> - let fc = Opaqueproof.get_direct_constraints o in - begin match Future.peek_val fc with - | None -> [Later fc] - | Some c -> [Now c] - end - | Undef _ | Def _ | Primitive _ | OpaqueDef _ -> [] - in (* This is the only place where we hashcons the contents of a constant body *) let cb = if in_section then cb else Declareops.hcons_const_body cb in let cb, otab = match cb.const_body with @@ -572,7 +605,6 @@ let add_constant_aux ~in_section senv (kn, cb) = in let senv = { senv with env = Environ.set_opaque_tables senv.env otab } in let senv' = add_field (l,SFBconst cb) (C kn) senv in - let senv' = add_constraints_list delayed_cst senv' in let senv'' = match cb.const_body with | Undef (Some lev) -> update_resolver @@ -787,15 +819,10 @@ let export_private_constants ~in_section ce senv = let map (kn, cb) = (kn, map_constant (fun c -> map cb.const_universes c) cb) in let bodies = List.map map exported in let exported = List.map (fun (kn, _) -> kn) exported in + (* No delayed constants to declare *) let senv = List.fold_left (add_constant_aux ~in_section) senv bodies in (ce, exported), senv -let add_recipe ~in_section l r senv = - let kn = Constant.make2 senv.modpath l in - let cb = Term_typing.translate_recipe senv.env kn r in - let senv = add_constant_aux ~in_section senv (kn, cb) in - kn, senv - let add_constant (type a) ~(side_effect : a effect_entry) ~in_section l decl senv : (Constant.t * a) * safe_environment = let kn = Constant.make2 senv.modpath l in let cb = @@ -811,8 +838,24 @@ let add_constant (type a) ~(side_effect : a effect_entry) ~in_section l decl sen Term_typing.translate_constant Term_typing.Pure senv.env kn ce in let senv = + let delayed_cst = match cb.const_body with + | OpaqueDef fc when not (Declareops.constant_is_polymorphic cb) -> + let map (_, u) = match u with + | Opaqueproof.PrivateMonomorphic ctx -> ctx + | Opaqueproof.PrivatePolymorphic _ -> assert false + in + let fc = Future.chain fc map in + begin match Future.peek_val fc with + | None -> [Later fc] + | Some c -> [Now c] + end + | Undef _ | Def _ | Primitive _ | OpaqueDef _ -> [] + in let cb = map_constant (fun c -> Opaqueproof.create c) cb in - add_constant_aux ~in_section senv (kn, cb) in + let senv = add_constant_aux ~in_section senv (kn, cb) in + add_constraints_list delayed_cst senv + in + let senv = match decl with | ConstantEntry (_,(Entries.PrimitiveEntry { Entries.prim_entry_content = CPrimitives.OT_type t; _ })) -> @@ -902,6 +945,74 @@ let add_module l me inl senv = in (mp,mb.mod_delta),senv'' +(** {6 Interactive sections *) + +let open_section ~poly senv = + let custom = { + rev_env = senv.env; + rev_univ = senv.univ; + rev_objlabels = senv.objlabels; + } in + let sections = Section.open_section ~poly ~custom senv.sections in + { senv with sections } + +let close_section senv = + let open Section in + let sections0 = senv.sections in + let env0 = senv.env in + (* First phase: revert the declarations added in the section *) + let sections, entries, cstrs, revert = Section.close_section sections0 in + let () = assert (not (Section.is_polymorphic sections0) || Univ.ContextSet.is_empty cstrs) in + let rec pop_revstruct accu entries revstruct = match entries, revstruct with + | [], revstruct -> accu, revstruct + | _ :: _, [] -> + CErrors.anomaly (Pp.str "Unmatched section data") + | entry :: entries, (lbl, leaf) :: revstruct -> + let data = match entry, leaf with + | SecDefinition kn, SFBconst cb -> + let () = assert (Label.equal lbl (Constant.label kn)) in + `Definition (kn, cb) + | SecInductive ind, SFBmind mib -> + let () = assert (Label.equal lbl (MutInd.label ind)) in + `Inductive (ind, mib) + | (SecDefinition _ | SecInductive _), (SFBconst _ | SFBmind _) -> + CErrors.anomaly (Pp.str "Section content mismatch") + | (SecDefinition _ | SecInductive _), (SFBmodule _ | SFBmodtype _) -> + CErrors.anomaly (Pp.str "Module inside a section") + in + pop_revstruct (data :: accu) entries revstruct + in + let redo, revstruct = pop_revstruct [] entries senv.revstruct in + (* Don't revert the delayed constraints. If some delayed constraints were + forced inside the section, they have been turned into global monomorphic + that are going to be replayed. Those that are not forced are not readded + by {!add_constant_aux}. *) + let { rev_env = env; rev_univ = univ; rev_objlabels = objlabels } = revert in + let senv = { senv with env; revstruct; sections; univ; objlabels; } in + (* Second phase: replay the discharged section contents *) + let senv = add_constraints (Now cstrs) senv in + let modlist = Section.replacement_context env0 sections0 in + let cooking_info seg = + let { abstr_ctx; abstr_subst; abstr_uctx } = seg in + let abstract = (abstr_ctx, abstr_subst, abstr_uctx) in + { Opaqueproof.modlist; abstract } + in + let fold senv = function + | `Definition (kn, cb) -> + let in_section = not (Section.is_empty senv.sections) in + let info = cooking_info (Section.segment_of_constant env0 kn sections0) in + let r = { Cooking.from = cb; info } in + let cb = Term_typing.translate_recipe senv.env kn r in + (* Delayed constants are already in the global environment *) + add_constant_aux ~in_section senv (kn, cb) + | `Inductive (ind, mib) -> + let info = cooking_info (Section.segment_of_inductive env0 ind sections0) in + let mie = Cooking.cook_inductive info mib in + let mie = InferCumulativity.infer_inductive senv.env mie in + let _, senv = add_mind (MutInd.label ind) mie senv in + senv + in + List.fold_left fold senv redo (** {6 Starting / ending interactive modules and module types } *) diff --git a/kernel/safe_typing.mli b/kernel/safe_typing.mli index fa53fa33fa..d3ca642a89 100644 --- a/kernel/safe_typing.mli +++ b/kernel/safe_typing.mli @@ -27,12 +27,16 @@ val digest_match : actual:vodigest -> required:vodigest -> bool type safe_environment +type section_data + val empty_environment : safe_environment val is_initial : safe_environment -> bool val env_of_safe_env : safe_environment -> Environ.env +val sections_of_safe_env : safe_environment -> section_data Section.t + (** The safe_environment state monad *) type safe_transformer0 = safe_environment -> safe_environment @@ -67,15 +71,6 @@ val join_safe_environment : val is_joined_environment : safe_environment -> bool (** {6 Enriching a safe environment } *) -(** Insertion of local declarations (Local or Variables) *) - -val push_named_assum : (Id.t * Constr.types) -> safe_transformer0 - -(** Returns the full universe context necessary to typecheck the definition - (futures are forced) *) -val push_named_def : - Id.t * Entries.section_def_entry -> safe_transformer0 - (** Insertion of global axioms or definitions *) type 'a effect_entry = @@ -96,9 +91,6 @@ val add_constant : side_effect:'a effect_entry -> in_section:bool -> Label.t -> global_declaration -> (Constant.t * 'a) safe_transformer -val add_recipe : - in_section:bool -> Label.t -> Cooking.recipe -> Constant.t safe_transformer - (** Adding an inductive type *) val add_mind : @@ -140,6 +132,22 @@ val set_allow_sprop : bool -> safe_transformer0 val check_engagement : Environ.env -> Declarations.set_predicativity -> unit +(** {6 Interactive section functions } *) + +val open_section : poly:bool -> safe_transformer0 + +val close_section : safe_transformer0 + +(** Insertion of local declarations (Local or Variables) *) + +val push_named_assum : (Id.t * Constr.types) -> safe_transformer0 + +val push_named_def : + Id.t * Entries.section_def_entry -> safe_transformer0 + +(** Add local universes to a polymorphic section *) +val push_section_context : (Name.t array * Univ.UContext.t) -> safe_transformer0 + (** {6 Interactive module functions } *) val start_module : Label.t -> ModPath.t safe_transformer diff --git a/kernel/section.ml b/kernel/section.ml new file mode 100644 index 0000000000..188249e77e --- /dev/null +++ b/kernel/section.ml @@ -0,0 +1,269 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Util +open Names +open Univ + +module NamedDecl = Context.Named.Declaration + +type _ section_kind = +| SecMono : [ `mono ] section_kind +| SecPoly : [ `poly ] section_kind + +type (_, 'a) section_universes = +| SecMonoUniv : 'a -> ([ `mono ], 'a) section_universes +| SecPolyUniv : Name.t array * UContext.t -> ([ `poly ], 'a) section_universes + +type section_entry = +| SecDefinition of Constant.t +| SecInductive of MutInd.t + +type 'a entry_map = 'a Cmap.t * 'a Mindmap.t + +type ('a, 'b) section = { + sec_context : int; + (** Length of the named context suffix that has been introduced locally *) + sec_universes : ('a, ContextSet.t) section_universes; + (** Universes local to the section *) + sec_entries : section_entry list; + (** Definitions introduced in the section *) + sec_data : ('a, unit) section_universes entry_map; + (** Additional data synchronized with the section *) + sec_custom : 'b; +} + +(** Sections can be nested with the proviso that no monomorphic section can be + opened inside a polymorphic one. The reverse is allowed. *) +type 'a t = { + sec_poly : ([ `poly ], 'a) section list; + sec_mono : ([ `mono ], 'a) section list; +} + +let empty = { + sec_poly = []; + sec_mono = []; +} + +let is_empty s = + List.is_empty s.sec_poly && List.is_empty s.sec_mono + +let is_polymorphic s = + not (List.is_empty s.sec_poly) + +let find_emap e (cmap, imap) = match e with +| SecDefinition con -> Cmap.find con cmap +| SecInductive ind -> Mindmap.find ind imap + +let add_emap e v (cmap, imap) = match e with +| SecDefinition con -> (Cmap.add con v cmap, imap) +| SecInductive ind -> (cmap, Mindmap.add ind v imap) + +type 'b on_sec = { on_sec : 'a. 'a section_kind -> ('a, 'b) section -> ('a, 'b) section } + +let on_last_section f { sec_poly; sec_mono } = match sec_poly, sec_mono with +| [], [] -> CErrors.user_err (Pp.str "No opened section") +| sec :: rem, _ -> + let sec_poly = f.on_sec SecPoly sec :: rem in + { sec_mono; sec_poly } +| [], sec :: rem -> + let sec_mono = f.on_sec SecMono sec :: rem in + { sec_mono; sec_poly } + +type ('r, 'b) with_sec = { with_sec : 'a. ('a section_kind * ('a, 'b) section) option -> 'r } + +let with_last_section f { sec_poly; sec_mono } = match sec_poly, sec_mono with +| [], [] -> f.with_sec None +| sec :: _, _ -> f.with_sec (Some (SecPoly, sec)) +| [], sec :: _ -> f.with_sec (Some (SecMono, sec)) + +let push_local s = + let on_sec _ sec = { sec with sec_context = sec.sec_context + 1 } in + on_last_section { on_sec } s + +let push_context (nas, ctx) s = + let on_sec (type a) (kind : a section_kind) (sec : (a, _) section) : (a, _) section = match kind with + | SecMono -> + CErrors.anomaly (Pp.str "Adding polymorphic constraints to monomorphic section") + | SecPoly -> + let SecPolyUniv (snas, sctx) = sec.sec_universes in + let sec_universes = SecPolyUniv (Array.append snas nas, UContext.union sctx ctx) in + { sec with sec_universes } + in + on_last_section { on_sec } s + +let push_constraints uctx s = + let on_sec (type a) (kind : a section_kind) (sec : (a, _) section) : (a, _) section = match kind with + | SecMono -> + let SecMonoUniv uctx' = sec.sec_universes in + let sec_universes = SecMonoUniv (ContextSet.union uctx uctx') in + { sec with sec_universes } + | SecPoly -> + CErrors.anomaly (Pp.str "Adding monomorphic constraints to polymorphic section") + in + on_last_section { on_sec } s + +let open_section ~poly ~custom sections = + if poly then + let sec = { + sec_context = 0; + sec_universes = SecPolyUniv ([||], Univ.UContext.empty); + sec_entries = []; + sec_data = (Cmap.empty, Mindmap.empty); + sec_custom = custom; + } in + { sections with sec_poly = sec :: sections.sec_poly } + else if List.is_empty sections.sec_poly then + let sec = { + sec_context = 0; + sec_universes = SecMonoUniv Univ.ContextSet.empty; + sec_entries = []; + sec_data = (Cmap.empty, Mindmap.empty); + sec_custom = custom; + } in + { sections with sec_mono = sec :: sections.sec_mono } + else + CErrors.user_err (Pp.str "Cannot open a monomorphic section inside a polymorphic one") + +let close_section sections = + match sections.sec_poly, sections.sec_mono with + | sec :: psecs, _ -> + let sections = { sections with sec_poly = psecs } in + sections, sec.sec_entries, Univ.ContextSet.empty, sec.sec_custom + | [], sec :: msecs -> + let sections = { sections with sec_mono = msecs } in + let SecMonoUniv cstrs = sec.sec_universes in + sections, sec.sec_entries, cstrs, sec.sec_custom + | [], [] -> + CErrors.user_err (Pp.str "No opened section.") + +let same_poly (type a) ~poly (knd : a section_kind) = match knd with +| SecPoly -> poly +| SecMono -> not poly + +let drop_global (type a) : (a, _) section_universes -> (a, unit) section_universes = function +| SecMonoUniv _ -> SecMonoUniv () +| SecPolyUniv _ as u -> u + +let push_global ~poly e s = + if is_empty s then s + else + let on_sec knd sec = + if same_poly ~poly knd then { sec with + sec_entries = e :: sec.sec_entries; + sec_data = add_emap e (drop_global sec.sec_universes) sec.sec_data; + } else + CErrors.user_err (Pp.str "Cannot mix universe polymorphic and \ + monomorphic declarations in sections.") + in + on_last_section { on_sec } s + +let push_constant ~poly con s = push_global ~poly (SecDefinition con) s + +let push_inductive ~poly ind s = push_global ~poly (SecInductive ind) s + +type abstr_info = { + abstr_ctx : Constr.named_context; + abstr_subst : Univ.Instance.t; + abstr_uctx : Univ.AUContext.t; +} + +let empty_segment = { + abstr_ctx = []; + abstr_subst = Instance.empty; + abstr_uctx = AUContext.empty; +} + +let extract_hyps sec vars hyps = + (* FIXME: this code is fishy. It is supposed to check that declared section + variables are an ordered subset of the ambient ones, but it doesn't check + e.g. uniqueness of naming nor convertibility of the section data. *) + let rec aux ids hyps = match ids, hyps with + | id :: ids, decl :: hyps when Names.Id.equal id (NamedDecl.get_id decl) -> + decl :: aux ids hyps + | _ :: ids, hyps -> + aux ids hyps + | [], _ -> [] + in + let ids = List.map NamedDecl.get_id @@ List.firstn sec.sec_context vars in + aux ids hyps + +let section_segment_of_entry vars e hyps sections = + (* [vars] are the named hypotheses, [hyps] the subset that is declared by the + global *) + let with_sec (type a) (s : (a section_kind * (a, _) section) option) = match s with + | None -> + CErrors.user_err (Pp.str "No opened section.") + | Some (knd, sec) -> + let hyps = extract_hyps sec vars hyps in + let inst, auctx = match knd, find_emap e sec.sec_data with + | SecMono, SecMonoUniv () -> + Instance.empty, AUContext.empty + | SecPoly, SecPolyUniv (nas, ctx) -> + Univ.abstract_universes nas ctx + in + { + abstr_ctx = hyps; + abstr_subst = inst; + abstr_uctx = auctx; + } + in + with_last_section { with_sec } sections + +let segment_of_constant env con s = + let body = Environ.lookup_constant con env in + let vars = Environ.named_context env in + section_segment_of_entry vars (SecDefinition con) body.Declarations.const_hyps s + +let segment_of_inductive env mind s = + let mib = Environ.lookup_mind mind env in + let vars = Environ.named_context env in + section_segment_of_entry vars (SecInductive mind) mib.Declarations.mind_hyps s + +let instance_from_variable_context = + List.rev %> List.filter NamedDecl.is_local_assum %> List.map NamedDecl.get_id %> Array.of_list + +let extract_worklist info = + let args = instance_from_variable_context info.abstr_ctx in + info.abstr_subst, args + +let replacement_context env s = + let with_sec sec = match sec with + | None -> CErrors.user_err (Pp.str "No opened section.") + | Some (_, sec) -> + let cmap, imap = sec.sec_data in + let cmap = Cmap.mapi (fun con _ -> extract_worklist @@ segment_of_constant env con s) cmap in + let imap = Mindmap.mapi (fun ind _ -> extract_worklist @@ segment_of_inductive env ind s) imap in + (cmap, imap) + in + with_last_section { with_sec } s + +let is_in_section env gr s = + let with_sec sec = match sec with + | None -> false + | Some (_, sec) -> + let open GlobRef in + match gr with + | VarRef id -> + let vars = List.firstn sec.sec_context (Environ.named_context env) in + List.exists (fun decl -> Id.equal id (NamedDecl.get_id decl)) vars + | ConstRef con -> + Cmap.mem con (fst sec.sec_data) + | IndRef (ind, _) | ConstructRef ((ind, _), _) -> + Mindmap.mem ind (snd sec.sec_data) + in + with_last_section { with_sec } s + +let is_polymorphic_univ u s = + let check sec = + let SecPolyUniv (_, uctx) = sec.sec_universes in + Array.mem u (Instance.to_array (UContext.instance uctx)) + in + List.exists check s.sec_poly diff --git a/kernel/section.mli b/kernel/section.mli new file mode 100644 index 0000000000..c1026a2980 --- /dev/null +++ b/kernel/section.mli @@ -0,0 +1,90 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Names +open Univ + +(** Kernel implementation of sections. *) + +type 'a t +(** Type of sections with additional data ['a] *) + +val empty : 'a t + +val is_empty : 'a t -> bool +(** Checks whether there is no opened section *) + +val is_polymorphic : 'a t -> bool +(** Checks whether last opened section is polymorphic *) + +(** {6 Manipulating sections} *) + +type section_entry = +| SecDefinition of Constant.t +| SecInductive of MutInd.t + +val open_section : poly:bool -> custom:'a -> 'a t -> 'a t +(** Open a new section with the provided universe polymorphic status. Sections + can be nested, with the proviso that polymorphic sections cannot appear + inside a monomorphic one. A custom data can be attached to this section, + that will be returned by {!close_section}. *) + +val close_section : 'a t -> 'a t * section_entry list * ContextSet.t * 'a +(** Close the current section and returns the entries defined inside, the set + of global monomorphic constraints added in this section, and the custom data + provided at the opening of the section. *) + +(** {6 Extending sections} *) + +val push_local : 'a t -> 'a t +(** Extend the current section with a local definition (cf. push_named). *) + +val push_context : Name.t array * UContext.t -> 'a t -> 'a t +(** Extend the current section with a local universe context. Assumes that the + last opened section is polymorphic. *) + +val push_constraints : ContextSet.t -> 'a t -> 'a t +(** Extend the current section with a global universe context. + Assumes that the last opened section is monomorphic. *) + +val push_constant : poly:bool -> Constant.t -> 'a t -> 'a t +(** Make the constant as having been defined in this section. *) + +val push_inductive : poly:bool -> MutInd.t -> 'a t -> 'a t +(** Make the inductive block as having been defined in this section. *) + +(** {6 Retrieving section data} *) + +type abstr_info = private { + abstr_ctx : Constr.named_context; + (** Section variables of this prefix *) + abstr_subst : Univ.Instance.t; + (** Actual names of the abstracted variables *) + abstr_uctx : Univ.AUContext.t; + (** Universe quantification, same length as the substitution *) +} +(** Data needed to abstract over the section variable and universe hypotheses *) + + +val empty_segment : abstr_info +(** Nothing to abstract *) + +val segment_of_constant : Environ.env -> Constant.t -> 'a t -> abstr_info +(** Section segment at the time of the constant declaration *) + +val segment_of_inductive : Environ.env -> MutInd.t -> 'a t -> abstr_info +(** Section segment at the time of the inductive declaration *) + +val replacement_context : Environ.env -> 'a t -> Opaqueproof.work_list +(** Section segments of all declarations from this section. *) + +val is_in_section : Environ.env -> GlobRef.t -> 'a t -> bool + +val is_polymorphic_univ : Level.t -> 'a t -> bool diff --git a/library/global.ml b/library/global.ml index 6bb4614aa4..315a147d2c 100644 --- a/library/global.ml +++ b/library/global.ml @@ -71,6 +71,11 @@ let globalize0 f = GlobalSafeEnv.set_safe_env (f (safe_env ())) let globalize f = let res,env = f (safe_env ()) in GlobalSafeEnv.set_safe_env env; res +let globalize0_with_summary fs f = + let env = f (safe_env ()) in + Summary.unfreeze_summaries fs; + GlobalSafeEnv.set_safe_env env + let globalize_with_summary fs f = let res,env = f (safe_env ()) in Summary.unfreeze_summaries fs; @@ -83,6 +88,7 @@ let i2l = Label.of_id let push_named_assum a = globalize0 (Safe_typing.push_named_assum a) let push_named_def d = globalize0 (Safe_typing.push_named_def d) +let push_section_context c = globalize0 (Safe_typing.push_section_context c) let add_constraints c = globalize0 (Safe_typing.add_constraints c) let push_context_set b c = globalize0 (Safe_typing.push_context_set b c) @@ -98,12 +104,14 @@ let set_allow_sprop b = globalize0 (Safe_typing.set_allow_sprop b) let sprop_allowed () = Environ.sprop_allowed (env()) let export_private_constants ~in_section cd = globalize (Safe_typing.export_private_constants ~in_section cd) let add_constant ~side_effect ~in_section id d = globalize (Safe_typing.add_constant ~side_effect ~in_section (i2l id) d) -let add_recipe ~in_section id d = globalize (Safe_typing.add_recipe ~in_section (i2l id) d) let add_mind id mie = globalize (Safe_typing.add_mind (i2l id) mie) let add_modtype id me inl = globalize (Safe_typing.add_modtype (i2l id) me inl) let add_module id me inl = globalize (Safe_typing.add_module (i2l id) me inl) let add_include me ismod inl = globalize (Safe_typing.add_include me ismod inl) +let open_section ~poly = globalize0 (Safe_typing.open_section ~poly) +let close_section fs = globalize0_with_summary fs Safe_typing.close_section + let start_module id = globalize (Safe_typing.start_module (i2l id)) let start_modtype id = globalize (Safe_typing.start_modtype (i2l id)) diff --git a/library/global.mli b/library/global.mli index d0bd556d70..26ccb90271 100644 --- a/library/global.mli +++ b/library/global.mli @@ -44,6 +44,7 @@ val sprop_allowed : unit -> bool val push_named_assum : (Id.t * Constr.types) -> unit val push_named_def : (Id.t * Entries.section_def_entry) -> unit +val push_section_context : (Name.t array * Univ.UContext.t) -> unit val export_private_constants : in_section:bool -> Safe_typing.private_constants Entries.proof_output -> @@ -51,7 +52,6 @@ val export_private_constants : in_section:bool -> val add_constant : side_effect:'a Safe_typing.effect_entry -> in_section:bool -> Id.t -> Safe_typing.global_declaration -> Constant.t * 'a -val add_recipe : in_section:bool -> Id.t -> Cooking.recipe -> Constant.t val add_mind : Id.t -> Entries.mutual_inductive_entry -> MutInd.t @@ -71,6 +71,15 @@ val add_include : Entries.module_struct_entry -> bool -> Declarations.inline -> Mod_subst.delta_resolver +(** Sections *) + +val open_section : poly:bool -> unit +(** [poly] is true when the section should be universe polymorphic *) + +val close_section : Summary.frozen -> unit +(** Close the section and reset the global state to the one at the time when + the section what opened. *) + (** Interactive modules and module types *) val start_module : Id.t -> ModPath.t diff --git a/library/lib.ml b/library/lib.ml index 851f086961..1c6f82e8a6 100644 --- a/library/lib.ml +++ b/library/lib.ml @@ -410,87 +410,11 @@ let find_opening_node id = - the list of substitution to do at section closing *) -type abstr_info = { +type abstr_info = Section.abstr_info = private { abstr_ctx : Constr.named_context; abstr_subst : Univ.Instance.t; abstr_uctx : Univ.AUContext.t; } -type abstr_list = abstr_info Names.Cmap.t * abstr_info Names.Mindmap.t - -type secentry = - | Variable of { - id:Names.Id.t; - } - | Context of Univ.ContextSet.t - -type section_data = { - sec_entry : secentry list; - sec_abstr : abstr_list; - sec_poly : bool; -} - -let empty_section_data ~poly = { - sec_entry = []; - sec_abstr = (Names.Cmap.empty,Names.Mindmap.empty); - sec_poly = poly; -} - -let sectab = - Summary.ref ([] : section_data list) ~name:"section-context" - -let check_same_poly p sec = - if p != sec.sec_poly then - user_err Pp.(str "Cannot mix universe polymorphic and monomorphic declarations in sections.") - -let add_section ~poly () = - List.iter (fun tab -> check_same_poly poly tab) !sectab; - sectab := empty_section_data ~poly :: !sectab - -let add_section_variable ~name ~poly = - match !sectab with - | [] -> () (* because (Co-)Fixpoint temporarily uses local vars *) - | s :: sl -> - List.iter (fun tab -> check_same_poly poly tab) !sectab; - let s = { s with sec_entry = Variable {id=name} :: s.sec_entry } in - sectab := s :: sl - -let add_section_context ctx = - match !sectab with - | [] -> () (* because (Co-)Fixpoint temporarily uses local vars *) - | s :: sl -> - check_same_poly true s; - let s = { s with sec_entry = Context ctx :: s.sec_entry } in - sectab := s :: sl - -exception PolyFound (* make this a let exception once possible *) -let is_polymorphic_univ u = - try - let open Univ in - List.iter (fun s -> - let vars = s.sec_entry in - List.iter (function - | Variable _ -> () - | Context (univs,_) -> - if LSet.mem u univs then raise PolyFound - ) vars - ) !sectab; - false - with PolyFound -> true - -let extract_hyps poly (secs,ohyps) = - let rec aux = function - | (Variable {id}::idl, decl::hyps) when Names.Id.equal id (NamedDecl.get_id decl) -> - let l, r = aux (idl,hyps) in - decl :: l, r - | (Variable _::idl,hyps) -> - let l, r = aux (idl,hyps) in - l, r - | (Context ctx :: idl, hyps) -> - let () = assert poly in - let l, r = aux (idl, hyps) in - l, Univ.ContextSet.union r ctx - | [], _ -> [],Univ.ContextSet.empty - in aux (secs,ohyps) let instance_from_variable_context = List.rev %> List.filter is_local_assum %> List.map NamedDecl.get_id %> Array.of_list @@ -499,66 +423,21 @@ let extract_worklist info = let args = instance_from_variable_context info.abstr_ctx in info.abstr_subst, args -let make_worklist (cmap, mmap) = - Cmap.map extract_worklist cmap, Mindmap.map extract_worklist mmap - -let name_instance inst = - (* FIXME: this should probably be done at an upper level, by storing the - name information in the section data structure. *) - 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 add_section_replacement g poly hyps = - match !sectab with - | [] -> () - | s :: sl -> - let () = check_same_poly poly s in - let sechyps,ctx = extract_hyps s.sec_poly (s.sec_entry, hyps) in - let ctx = Univ.ContextSet.to_context ctx in - let nas = name_instance (Univ.UContext.instance ctx) in - let subst, ctx = Univ.abstract_universes nas ctx in - let info = { - abstr_ctx = sechyps; - abstr_subst = subst; - abstr_uctx = ctx; - } in - let s = { s with - sec_abstr = g info s.sec_abstr; - } in - sectab := s :: sl - -let add_section_kn ~poly kn = - let f x (l1,l2) = (l1,Names.Mindmap.add kn x l2) in - add_section_replacement f poly - -let add_section_constant ~poly kn = - let f x (l1,l2) = (Names.Cmap.add kn x l1,l2) in - add_section_replacement f poly - -let replacement_context () = make_worklist (List.hd !sectab).sec_abstr +let sections () = Safe_typing.sections_of_safe_env @@ Global.safe_env () + +let is_polymorphic_univ u = + Section.is_polymorphic_univ u (sections ()) + +let replacement_context () = + Section.replacement_context (Global.env ()) (sections ()) let section_segment_of_constant con = - Names.Cmap.find con (fst (List.hd !sectab).sec_abstr) + Section.segment_of_constant (Global.env ()) con (sections ()) let section_segment_of_mutual_inductive kn = - Names.Mindmap.find kn (snd (List.hd !sectab).sec_abstr) + Section.segment_of_inductive (Global.env ()) kn (sections ()) -let empty_segment = { - abstr_ctx = []; - abstr_subst = Univ.Instance.empty; - abstr_uctx = Univ.AUContext.empty; -} +let empty_segment = Section.empty_segment let section_segment_of_reference = let open GlobRef in function | ConstRef c -> section_segment_of_constant c @@ -569,28 +448,24 @@ let section_segment_of_reference = let open GlobRef in function let variable_section_segment_of_reference gr = (section_segment_of_reference gr).abstr_ctx +let is_in_section ref = + Section.is_in_section (Global.env ()) ref (sections ()) + let section_instance = let open GlobRef in function | VarRef id -> - let eq = function - | Variable {id=id'} -> Names.Id.equal id id' - | Context _ -> false - in - if List.exists eq (List.hd !sectab).sec_entry - then Univ.Instance.empty, [||] - else raise Not_found + if is_in_section (VarRef id) then (Univ.Instance.empty, [||]) + else raise Not_found | ConstRef con -> - let data = Names.Cmap.find con (fst (List.hd !sectab).sec_abstr) in + let data = section_segment_of_constant con in extract_worklist data | IndRef (kn,_) | ConstructRef ((kn,_),_) -> - let data = Names.Mindmap.find kn (snd (List.hd !sectab).sec_abstr) in + let data = section_segment_of_mutual_inductive kn in extract_worklist data -let is_in_section ref = - try ignore (section_instance ref); true with Not_found -> false - (*************) (* Sections. *) let open_section ~poly id = + let () = Global.open_section ~poly in let opp = !lib_state.path_prefix in let obj_dir = add_dirpath_suffix opp.Nametab.obj_dir id in let prefix = Nametab.{ obj_dir; obj_mp = opp.obj_mp; obj_sec = add_dirpath_suffix opp.obj_sec id } in @@ -600,9 +475,7 @@ let open_section ~poly id = add_entry (make_foname id) (OpenedSection (prefix, fs)); (*Pushed for the lifetime of the section: removed by unfrozing the summary*) Nametab.(push_dir (Until 1) obj_dir (GlobDirRef.DirOpenSection prefix)); - lib_state := { !lib_state with path_prefix = prefix }; - add_section ~poly () - + lib_state := { !lib_state with path_prefix = prefix } (* Restore lib_stk and summaries as before the section opening, and add a ClosedSection object. *) @@ -631,7 +504,7 @@ let close_section () = lib_state := { !lib_state with lib_stk = before }; pop_path_prefix (); let newdecls = List.map discharge_item secdecls in - Summary.unfreeze_summaries fs; + let () = Global.close_section fs in List.iter (Option.iter (fun (id,o) -> add_discharged_leaf id o)) newdecls (* State and initialization. *) diff --git a/library/lib.mli b/library/lib.mli index 9ffa69ef93..5ce601f2d3 100644 --- a/library/lib.mli +++ b/library/lib.mli @@ -163,7 +163,7 @@ val drop_objects : frozen -> frozen val init : unit -> unit (** {6 Section management for discharge } *) -type abstr_info = private { +type abstr_info = Section.abstr_info = private { abstr_ctx : Constr.named_context; (** Section variables of this prefix *) abstr_subst : Univ.Instance.t; @@ -181,10 +181,6 @@ val variable_section_segment_of_reference : GlobRef.t -> Constr.named_context val section_instance : GlobRef.t -> Univ.Instance.t * Id.t array val is_in_section : GlobRef.t -> bool -val add_section_variable : name:Id.t -> poly:bool -> unit -val add_section_context : Univ.ContextSet.t -> unit -val add_section_constant : poly:bool -> Constant.t -> Constr.named_context -> unit -val add_section_kn : poly:bool -> MutInd.t -> Constr.named_context -> unit val replacement_context : unit -> Opaqueproof.work_list val is_polymorphic_univ : Univ.Level.t -> bool diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index ca33e4e757..7be049269c 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -920,20 +920,10 @@ let generate_equation_lemma evd fnames f fun_num nb_params nb_args rec_args_num ] in (* Pp.msgnl (str "lemma type (2) " ++ Printer.pr_lconstr_env (Global.env ()) evd lemma_type); *) - let info = Lemmas.Info.make - ~scope:(DeclareDef.Global Declare.ImportDefaultBehavior) - ~kind:(Decls.(IsProof Theorem)) () in - - let lemma = Lemmas.start_lemma - (*i The next call to mk_equation_id is valid since we are constructing the lemma - Ensures by: obvious - i*) - ~name:(mk_equation_id f_id) - ~poly:false - ~info - evd - lemma_type - in + + (*i The next call to mk_equation_id is valid since we are + constructing the lemma Ensures by: obvious i*) + let lemma = Lemmas.start_lemma ~name:(mk_equation_id f_id) ~poly:false evd lemma_type in let lemma,_ = Lemmas.by (Proofview.V82.tactic prove_replacement) lemma in let () = Lemmas.save_lemma_proved ~lemma ~opaque:Proof_global.Transparent ~idopt:None in evd diff --git a/plugins/funind/gen_principle.ml b/plugins/funind/gen_principle.ml index 570b72136c..6011af74e5 100644 --- a/plugins/funind/gen_principle.ml +++ b/plugins/funind/gen_principle.ml @@ -1387,15 +1387,7 @@ let derive_correctness (funs: Constr.pconstant list) (graphs:inductive list) = i*) let lem_id = mk_correct_id f_id in let (typ,_) = lemmas_types_infos.(i) in - let info = Lemmas.Info.make - ~scope:(DeclareDef.Global Declare.ImportDefaultBehavior) - ~kind:(Decls.(IsProof Theorem)) () in - let lemma = Lemmas.start_lemma - ~name:lem_id - ~poly:false - ~info - !evd - typ in + let lemma = Lemmas.start_lemma ~name:lem_id ~poly:false !evd typ in let lemma = fst @@ Lemmas.by (Proofview.V82.tactic (proving_tac i)) lemma in let () = Lemmas.save_lemma_proved ~lemma ~opaque:Proof_global.Transparent ~idopt:None in @@ -1456,11 +1448,7 @@ let derive_correctness (funs: Constr.pconstant list) (graphs:inductive list) = Ensures by: obvious i*) let lem_id = mk_complete_id f_id in - let info = Lemmas.Info.make - ~scope:(DeclareDef.Global Declare.ImportDefaultBehavior) - ~kind:Decls.(IsProof Theorem) () in - let lemma = Lemmas.start_lemma ~name:lem_id ~poly:false ~info - sigma (fst lemmas_types_infos.(i)) in + let lemma = Lemmas.start_lemma ~name:lem_id ~poly:false sigma (fst lemmas_types_infos.(i)) in let lemma = fst (Lemmas.by (Proofview.V82.tactic (observe_tac ("prove completeness ("^(Id.to_string f_id)^")") (proving_tac i))) lemma) in diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index c62aa0cf6b..4c5eab1a9b 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -1332,9 +1332,7 @@ let open_new_goal ~lemma build_proof sigma using_lemmas ref_ goal_name (gls_type let lemma = build_proof env (Evd.from_env env) start_tac end_tac in Lemmas.save_lemma_proved ~lemma ~opaque:opacity ~idopt:None in - let info = Lemmas.Info.make ~hook:(DeclareDef.Hook.make hook) - ~scope:(DeclareDef.Global Declare.ImportDefaultBehavior) ~kind:(Decls.(IsProof Lemma)) - () in + let info = Lemmas.Info.make ~hook:(DeclareDef.Hook.make hook) () in let lemma = Lemmas.start_lemma ~name:na ~poly:false (* FIXME *) ~info @@ -1376,7 +1374,7 @@ let com_terminate nb_args ctx hook = let start_proof env ctx tac_start tac_end = - let info = Lemmas.Info.make ~hook ~scope:(DeclareDef.Global ImportDefaultBehavior) ~kind:Decls.(IsProof Lemma) () in + let info = Lemmas.Info.make ~hook () in let lemma = Lemmas.start_lemma ~name:thm_name ~poly:false (*FIXME*) ~info diff --git a/plugins/ltac/tacarg.ml b/plugins/ltac/tacarg.ml index 9e8e86d4fc..252c15478d 100644 --- a/plugins/ltac/tacarg.ml +++ b/plugins/ltac/tacarg.ml @@ -20,7 +20,7 @@ let make0 ?dyn name = wit let wit_intropattern = make0 "intropattern" (* To keep after deprecation phase but it will get a different parsing semantics (Tactic Notation and TACTIC EXTEND) in pltac.ml *) -let wit_simple_intropattern = make0 "simple_intropattern" +let wit_simple_intropattern = make0 ~dyn:(val_tag (topwit wit_intropattern)) "simple_intropattern" let wit_quant_hyp = make0 "quant_hyp" let wit_constr_with_bindings = make0 "constr_with_bindings" let wit_open_constr_with_bindings = make0 "open_constr_with_bindings" diff --git a/plugins/ltac/taccoerce.ml b/plugins/ltac/taccoerce.ml index e64129d204..da89a027e2 100644 --- a/plugins/ltac/taccoerce.ml +++ b/plugins/ltac/taccoerce.ml @@ -145,11 +145,8 @@ let coerce_to_constr_context v = else raise (CannotCoerceTo "a term context") let is_intro_pattern v = - if has_type v (topwit wit_intropattern [@warning "-3"]) then - Some (out_gen (topwit wit_intropattern [@warning "-3"]) v).CAst.v - else - if has_type v (topwit wit_simple_intropattern) then - Some (out_gen (topwit wit_simple_intropattern) v).CAst.v + if has_type v (topwit wit_intro_pattern) then + Some (out_gen (topwit wit_intro_pattern) v).CAst.v else None diff --git a/plugins/micromega/ZifyInst.v b/plugins/micromega/ZifyInst.v index 3c44113604..1217e8a5f7 100644 --- a/plugins/micromega/ZifyInst.v +++ b/plugins/micromega/ZifyInst.v @@ -172,6 +172,10 @@ Program Instance Op_Z_of_N : UnOp Z.of_N := { TUOp := (fun x => x) ; TUOpInj := fun x => eq_refl (Z.of_N x) }. Add UnOp Op_Z_of_N. +Instance Op_Z_to_N : UnOp Z.to_N := + { TUOp := fun x => Z.max 0 x ; TUOpInj := ltac:(now intro x; destruct x) }. +Add UnOp Op_Z_to_N. + Instance Op_Z_neg : UnOp Z.neg := { TUOp := Z.opp ; TUOpInj := (fun x => eq_refl (Zneg x))}. Add UnOp Op_Z_neg. diff --git a/pretyping/pretyping.mllib b/pretyping/pretyping.mllib index 0ca39f0404..7e140f4399 100644 --- a/pretyping/pretyping.mllib +++ b/pretyping/pretyping.mllib @@ -4,7 +4,6 @@ Locusops Pretype_errors Reductionops Inductiveops -InferCumulativity Arguments_renaming Retyping Vnorm diff --git a/tactics/declare.ml b/tactics/declare.ml index 3a02e5451a..e418240d3a 100644 --- a/tactics/declare.ml +++ b/tactics/declare.ml @@ -35,22 +35,36 @@ type import_status = ImportDefaultBehavior | ImportNeedQualified (** Monomorphic universes need to survive sections. *) -let input_universe_context : Univ.ContextSet.t -> Libobject.obj = - declare_object @@ local_object "Monomorphic section universes" - ~cache:(fun (na, uctx) -> Global.push_context_set false uctx) - ~discharge:(fun (_, x) -> Some x) +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 - (Global.push_context_set true ctx; Lib.add_section_context ctx) + (* FIXME: some upper layers declare universes several times, we hack around + by checking whether the universes already exist. *) + let (univs, cstr) = ctx in + let univs = Univ.LSet.filter (fun u -> not (Lib.is_polymorphic_univ u)) univs in + let uctx = Univ.ContextSet.to_context (univs, cstr) in + let nas = name_instance (Univ.UContext.instance uctx) in + Global.push_section_context (nas, uctx) else - Lib.add_anonymous_leaf (input_universe_context ctx) + Global.push_context_set false ctx (** Declaration of constants and parameters *) type constant_obj = { - cst_decl : Cooking.recipe option; - (** Non-empty only when rebuilding a constant after a section *) cst_kind : Decls.logical_kind; cst_locl : import_status; } @@ -81,12 +95,6 @@ let load_constant i ((sp,kn), obj) = Nametab.push (Nametab.Until i) sp (GlobRef.ConstRef con); Dumpglob.add_constant_kind con obj.cst_kind -let cooking_info segment = - let modlist = replacement_context () in - let { abstr_ctx = named_ctx; abstr_subst = subst; abstr_uctx = uctx } = segment in - let abstract = (named_ctx, subst, uctx) in - { Opaqueproof.modlist; abstract } - (* Opening means making the name without its module qualification available *) let open_constant i ((sp,kn), obj) = (* Never open a local definition *) @@ -106,33 +114,20 @@ let check_exists id = let cache_constant ((sp,kn), obj) = (* Invariant: the constant must exist in the logical environment, except when redefining it when exiting a section. See [discharge_constant]. *) - let id = Libnames.basename sp in let kn' = - match obj.cst_decl with - | None -> - if Global.exists_objlabel (Label.of_id (Libnames.basename sp)) - then Constant.make1 kn - else CErrors.anomaly Pp.(str"Missing constant " ++ Id.print(Libnames.basename sp) ++ str".") - | Some r -> - Global.add_recipe ~in_section:(Lib.sections_are_opened ()) id r + if Global.exists_objlabel (Label.of_id (Libnames.basename sp)) + then Constant.make1 kn + else CErrors.anomaly Pp.(str"Missing constant " ++ Id.print(Libnames.basename sp) ++ str".") in assert (Constant.equal kn' (Constant.make1 kn)); Nametab.push (Nametab.Until 1) sp (GlobRef.ConstRef (Constant.make1 kn)); - let cst = Global.lookup_constant kn' in - add_section_constant ~poly:(Declareops.constant_is_polymorphic cst) kn' cst.const_hyps; Dumpglob.add_constant_kind (Constant.make1 kn) obj.cst_kind let discharge_constant ((sp, kn), obj) = - let con = Constant.make1 kn in - let from = Global.lookup_constant con in - let info = cooking_info (section_segment_of_constant con) in - (* This is a hack: when leaving a section, we lose the constant definition, so - we have to store it in the libobject to be able to retrieve it after. *) - Some { obj with cst_decl = Some { Cooking.from; info } } + Some obj (* Hack to reduce the size of .vo: we keep only what load/open needs *) let dummy_constant cst = { - cst_decl = None; cst_kind = cst.cst_kind; cst_locl = cst.cst_locl; } @@ -157,7 +152,6 @@ let update_tables c = let register_constant kn kind local = let o = inConstant { - cst_decl = None; cst_kind = kind; cst_locl = local; } in @@ -352,7 +346,6 @@ let declare_variable ~name ~kind d = poly in Nametab.push (Nametab.Until 1) (Libnames.make_path DirPath.empty name) (GlobRef.VarRef name); - add_section_variable ~name ~poly; Decls.(add_variable_data name {opaque;kind}); add_anonymous_leaf (inVariable ()); Impargs.declare_var_implicits ~impl name; @@ -366,12 +359,17 @@ let declare_inductive_argument_scopes kn mie = Notation.declare_ref_arguments_scope Evd.empty (GlobRef.ConstructRef ((kn,i),j)); done) mie.mind_entry_inds -let inductive_names sp kn mie = +type inductive_obj = { + ind_names : (Id.t * Id.t list) list + (* For each block, name of the type + name of constructors *) +} + +let inductive_names sp kn obj = let (dp,_) = Libnames.repr_path sp in let kn = Global.mind_of_delta_kn kn in let names, _ = List.fold_left - (fun (names, n) ind -> + (fun (names, n) (typename, consnames) -> let ind_p = (kn,n) in let names, _ = List.fold_left @@ -380,70 +378,37 @@ let inductive_names sp kn mie = Libnames.make_path dp l in ((sp, GlobRef.ConstructRef (ind_p,p)) :: names, p+1)) - (names, 1) ind.mind_entry_consnames in - let sp = Libnames.make_path dp ind.mind_entry_typename + (names, 1) consnames in + let sp = Libnames.make_path dp typename in ((sp, GlobRef.IndRef ind_p) :: names, n+1)) - ([], 0) mie.mind_entry_inds + ([], 0) obj.ind_names in names -let load_inductive i ((sp,kn),mie) = - let names = inductive_names sp kn mie in +let load_inductive i ((sp, kn), names) = + let names = inductive_names sp kn names in List.iter (fun (sp, ref) -> Nametab.push (Nametab.Until i) sp ref ) names -let open_inductive i ((sp,kn),mie) = - let names = inductive_names sp kn mie in +let open_inductive i ((sp, kn), names) = + let names = inductive_names sp kn names in List.iter (fun (sp, ref) -> Nametab.push (Nametab.Exactly i) sp ref) names -let cache_inductive ((sp,kn),mie) = - let names = inductive_names sp kn mie in - List.iter check_exists (List.map (fun p -> Libnames.basename (fst p)) names); - let id = Libnames.basename sp in - let kn' = Global.add_mind id mie in - assert (MutInd.equal kn' (MutInd.make1 kn)); - let mind = Global.lookup_mind kn' in - add_section_kn ~poly:(Declareops.inductive_is_polymorphic mind) kn' mind.mind_hyps; +let cache_inductive ((sp, kn), names) = + let names = inductive_names sp kn names in List.iter (fun (sp, ref) -> Nametab.push (Nametab.Until 1) sp ref) names -let discharge_inductive ((sp,kn),mie) = - let mind = Global.mind_of_delta_kn kn in - let mie = Global.lookup_mind mind in - let info = cooking_info (section_segment_of_mutual_inductive mind) in - Some (Cooking.cook_inductive info mie) - -let dummy_one_inductive_entry mie = { - mind_entry_typename = mie.mind_entry_typename; - mind_entry_arity = Constr.mkProp; - mind_entry_template = false; - mind_entry_consnames = mie.mind_entry_consnames; - mind_entry_lc = [] -} - -(* Hack to reduce the size of .vo: we keep only what load/open needs *) -let dummy_inductive_entry m = { - mind_entry_params = []; - mind_entry_record = None; - mind_entry_finite = Declarations.BiFinite; - mind_entry_inds = List.map dummy_one_inductive_entry m.mind_entry_inds; - mind_entry_universes = default_univ_entry; - mind_entry_variance = None; - mind_entry_private = None; -} - -(* reinfer subtyping constraints for inductive after section is dischared. *) -let rebuild_inductive mind_ent = - let env = Global.env () in - InferCumulativity.infer_inductive env mind_ent +let discharge_inductive ((sp, kn), names) = + Some names -let inInductive : mutual_inductive_entry -> obj = +let inInductive : inductive_obj -> obj = declare_object {(default_object "INDUCTIVE") with cache_function = cache_inductive; load_function = load_inductive; open_function = open_inductive; - classify_function = (fun a -> Substitute (dummy_inductive_entry a)); + classify_function = (fun a -> Substitute a); subst_function = ident_subst_function; discharge_function = discharge_inductive; - rebuild_function = rebuild_inductive } + } let cache_prim (_,(p,c)) = Recordops.register_primitive_projection p c @@ -500,7 +465,11 @@ let declare_mind mie = let id = match mie.mind_entry_inds with | ind::_ -> ind.mind_entry_typename | [] -> CErrors.anomaly (Pp.str "cannot declare an empty list of inductives.") in - let (sp,kn as oname) = add_leaf id (inInductive mie) in + let map_names mip = (mip.mind_entry_typename, mip.mind_entry_consnames) in + let names = List.map map_names mie.mind_entry_inds in + List.iter (fun (typ, cons) -> check_exists typ; List.iter check_exists cons) names; + let _kn' = Global.add_mind id mie in + let (sp,kn as oname) = add_leaf id (inInductive { ind_names = names }) in if is_unsafe_typing_flags() then feedback_axiom(); let mind = Global.mind_of_delta_kn kn in let isprim = declare_projections mie.mind_entry_universes mind in @@ -632,9 +601,9 @@ let do_universe ~poly l = let ctx = List.fold_left (fun ctx (_,qid) -> Univ.LSet.add (Univ.Level.make qid) ctx) Univ.LSet.empty l, Univ.Constraint.empty in - let () = declare_universe_context ~poly ctx in let src = if poly then BoundUniv else UnqualifiedUniv in - Lib.add_anonymous_leaf (input_univ_names (src, l)) + let () = Lib.add_anonymous_leaf (input_univ_names (src, l)) in + declare_universe_context ~poly ctx let do_constraint ~poly l = let open Univ in diff --git a/test-suite/bugs/closed/bug_10757.v b/test-suite/bugs/closed/bug_10757.v new file mode 100644 index 0000000000..a531f6e563 --- /dev/null +++ b/test-suite/bugs/closed/bug_10757.v @@ -0,0 +1,38 @@ +Require Import Program Extraction ExtrOcamlBasic. +Print sig. +Section FIXPOINT. + +Variable A: Type. + +Variable eq: A -> A -> Prop. +Variable beq: A -> A -> bool. +Hypothesis beq_eq: forall x y, beq x y = true -> eq x y. +Hypothesis beq_neq: forall x y, beq x y = false -> ~eq x y. + +Variable le: A -> A -> Prop. +Hypothesis le_trans: forall x y z, le x y -> le y z -> le x z. + +Definition gt (x y: A) := le y x /\ ~eq y x. +Hypothesis gt_wf: well_founded gt. + +Variable F: A -> A. +Hypothesis F_mon: forall x y, le x y -> le (F x) (F y). + +Program Fixpoint iterate + (x: A) (PRE: le x (F x)) (SMALL: forall z, le (F z) z -> le x z) + {wf gt x} + : {y : A | eq y (F y) /\ forall z, le (F z) z -> le y z } := + let x' := F x in + match beq x x' with + | true => x + | false => iterate x' _ _ + end. +Next Obligation. + split. +- auto. +- apply beq_neq. auto. +Qed. + +End FIXPOINT. + +Recursive Extraction iterate. diff --git a/test-suite/bugs/closed/bug_10778.v b/test-suite/bugs/closed/bug_10778.v new file mode 100644 index 0000000000..25d729b7e6 --- /dev/null +++ b/test-suite/bugs/closed/bug_10778.v @@ -0,0 +1,32 @@ +(* Test that fresh avoid the variables of intro patterns but also of + simple intro patterns *) + +Ltac exploit_main t T pat cleanup + := + (lazymatch T with + | ?U1 -> ?U2 => + let H := fresh + in +idtac "H=" H; + assert U1 as H; + [cleanup () | exploit_main (t H) U2 pat ltac:(fun _ => clear H; cleanup ())] + | _ => + pose proof t as pat; + cleanup () + end). + +Tactic Notation "exploit" constr(t) "as" simple_intropattern(pat) + := + exploit_main t ltac:(type of t) pat ltac:(fun _ => idtac). + +Goal (True -> True) -> True. +intro H0. exploit H0 as H. +Abort. + +Tactic Notation "exploit'" constr(t) "as" intropattern(pat) + := + exploit_main t ltac:(type of t) pat ltac:(fun _ => idtac). + +Goal (True -> True) -> True. +intro H0. exploit' H0 as H. +Abort. diff --git a/test-suite/ltac2/constr.v b/test-suite/ltac2/constr.v new file mode 100644 index 0000000000..39601d99a8 --- /dev/null +++ b/test-suite/ltac2/constr.v @@ -0,0 +1,12 @@ +Require Import Ltac2.Constr Ltac2.Init Ltac2.Control. +Import Unsafe. + +Ltac2 Eval match (kind '(nat -> bool)) with + | Prod a b c => a + | _ => throw Match_failure end. + +Set Allow StrictProp. +Axiom something : SProp. +Ltac2 Eval match (kind '(forall x : something, bool)) with + | Prod a b c => a + | _ => throw Match_failure end. diff --git a/test-suite/micromega/bug_9162.v b/test-suite/micromega/bug_9162.v new file mode 100644 index 0000000000..4aedf57faf --- /dev/null +++ b/test-suite/micromega/bug_9162.v @@ -0,0 +1,8 @@ +Require Import ZArith Lia. +Local Open Scope Z_scope. + +Goal Z.of_N (Z.to_N 0) = 0. +Proof. lia. Qed. + +Goal forall q, (Z.of_N (Z.to_N 0) = 0 -> q = 0) -> Z.of_N (Z.to_N 0) = q. +Proof. lia. Qed. diff --git a/test-suite/prerequisite/ssr_mini_mathcomp.v b/test-suite/prerequisite/ssr_mini_mathcomp.v index 74f94a9bed..d293dc0533 100644 --- a/test-suite/prerequisite/ssr_mini_mathcomp.v +++ b/test-suite/prerequisite/ssr_mini_mathcomp.v @@ -196,7 +196,7 @@ Definition clone_subType U v := Variable sT : subType. -CoInductive Sub_spec : sT -> Type := SubSpec x Px : Sub_spec (Sub x Px). +Variant Sub_spec : sT -> Type := SubSpec x Px : Sub_spec (Sub x Px). Lemma SubP u : Sub_spec u. Proof. by case: sT Sub_spec SubSpec u => T' _ C rec /= _. Qed. @@ -209,7 +209,7 @@ Definition insub x := Definition insubd u0 x := odflt u0 (insub x). -CoInductive insub_spec x : option sT -> Type := +Variant insub_spec x : option sT -> Type := | InsubSome u of P x & val u = x : insub_spec x (Some u) | InsubNone of ~~ P x : insub_spec x None. @@ -568,7 +568,7 @@ Fixpoint nth s n {struct n} := Fixpoint rcons s z := if s is x :: s' then x :: rcons s' z else [:: z]. -CoInductive last_spec : seq T -> Type := +Variant last_spec : seq T -> Type := | LastNil : last_spec [::] | LastRcons s x : last_spec (rcons s x). @@ -1292,7 +1292,7 @@ Open Scope big_scope. (* packages both in in a term in which i occurs; it also depends on the *) (* iterated <op>, as this can give more information on the expected type of *) (* the <general_term>, thus allowing for the insertion of coercions. *) -CoInductive bigbody R I := BigBody of I & (R -> R -> R) & bool & R. +Variant bigbody R I := BigBody of I & (R -> R -> R) & bool & R. Definition applybig {R I} (body : bigbody R I) x := let: BigBody _ op b v := body in if b then op v x else x. diff --git a/theories/Init/Logic.v b/theories/Init/Logic.v index 09a32e9483..4d84d61f9f 100644 --- a/theories/Init/Logic.v +++ b/theories/Init/Logic.v @@ -274,6 +274,22 @@ Inductive ex (A:Type) (P:A -> Prop) : Prop := ex_intro : forall x:A, P x -> ex (A:=A) P. Register ex as core.ex.type. +Register ex_intro as core.ex.intro. + +Section Projections. + + Variables (A:Prop) (P:A->Prop). + + Definition ex_proj1 (x:ex P) : A := + match x with ex_intro _ a _ => a end. + + Definition ex_proj2 (x:ex P) : P (ex_proj1 x) := + match x with ex_intro _ _ b => b end. + + Register ex_proj1 as core.ex.proj1. + Register ex_proj2 as core.ex.proj2. + +End Projections. Inductive ex2 (A:Type) (P Q:A -> Prop) : Prop := ex_intro2 : forall x:A, P x -> Q x -> ex2 (A:=A) P Q. diff --git a/theories/Reals/ConstructiveCauchyReals.v b/theories/Reals/ConstructiveCauchyReals.v index 004854e751..965d31d403 100644 --- a/theories/Reals/ConstructiveCauchyReals.v +++ b/theories/Reals/ConstructiveCauchyReals.v @@ -15,34 +15,32 @@ Require Import Qround. Require Import Logic.ConstructiveEpsilon. Require CMorphisms. -Open Scope Q. +(** The constructive Cauchy real numbers, ie the Cauchy sequences + of rational numbers. This file is not supposed to be imported, + except in Rdefinitions.v, Raxioms.v, Rcomplete_constr.v + and ConstructiveRIneq.v. -(* The constructive Cauchy real numbers, ie the Cauchy sequences - of rational numbers. This file is not supposed to be imported, - except in Rdefinitions.v, Raxioms.v, Rcomplete_constr.v - and ConstructiveRIneq.v. + Constructive real numbers should be considered abstractly, + forgetting the fact that they are implemented as rational sequences. + All useful lemmas of this file are exposed in ConstructiveRIneq.v, + under more abstract names, like Rlt_asym instead of CRealLt_asym. - Constructive real numbers should be considered abstractly, - forgetting the fact that they are implemented as rational sequences. - All useful lemmas of this file are exposed in ConstructiveRIneq.v, - under more abstract names, like Rlt_asym instead of CRealLt_asym. + Cauchy reals are Cauchy sequences of rational numbers, + equipped with explicit moduli of convergence and + an equivalence relation (the difference converges to zero). - Cauchy reals are Cauchy sequences of rational numbers, - equipped with explicit moduli of convergence and - an equivalence relation (the difference converges to zero). + Without convergence moduli, we would fail to prove that a Cauchy + sequence of constructive reals converges. - Without convergence moduli, we would fail to prove that a Cauchy - sequence of constructive reals converges. + Because of the Specker sequences (increasing, computable + and bounded sequences of rationals that do not converge + to a computable real number), constructive reals do not + follow the least upper bound principle. - Because of the Specker sequences (increasing, computable - and bounded sequences of rationals that do not converge - to a computable real number), constructive reals do not - follow the least upper bound principle. - - 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. + 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. *) Definition QSeqEquiv (un vn : nat -> Q) (cvmod : positive -> nat) : Prop @@ -213,7 +211,7 @@ Delimit Scope CReal_scope with CReal. (* Automatically open scope R_scope for arguments of type R *) Bind Scope CReal_scope with CReal. -Open Scope CReal_scope. +Local Open Scope CReal_scope. (* So QSeqEquiv is the equivalence relation of this constructive pre-order *) @@ -470,7 +468,8 @@ 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 (Pos.to_nat p) + - proj1_sig x (Pos.to_nat p)) }. Proof. intros x y [n maj]. pose proof (CRealLt_aboveSig x y n maj). @@ -544,10 +543,9 @@ Proof. Qed. Lemma CRealLt_dec : forall x y z : CReal, - CRealLt x y -> CRealLt x z + CRealLt z y. + x < y -> sum (x < z) (z < y). Proof. - intros [xn limx] [yn limy] [zn limz] clt. - destruct clt as [n inf]. + 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. assert (Qlt 0 eps) as epsPos. @@ -629,33 +627,33 @@ Defined. Definition linear_order_T x y z := CRealLt_dec x z y. -Lemma CRealLe_Lt_trans : forall x y z : CReal, +Lemma CReal_le_lt_trans : forall x y z : CReal, x <= y -> y < z -> x < z. Proof. intros. destruct (linear_order_T y x z H0). contradiction. apply c. -Qed. +Defined. -Lemma CRealLt_Le_trans : forall x y z : CReal, +Lemma CReal_lt_le_trans : forall x y z : CReal, x < y -> y <= z -> x < z. Proof. intros. destruct (linear_order_T x z y H). apply c. contradiction. -Qed. +Defined. -Lemma CRealLe_trans : forall x y z : CReal, +Lemma CReal_le_trans : forall x y z : CReal, x <= y -> y <= z -> x <= z. Proof. intros. intro abs. apply H0. - apply (CRealLt_Le_trans _ x); assumption. + apply (CReal_lt_le_trans _ x); assumption. Qed. -Lemma CRealLt_trans : forall x y z : CReal, +Lemma CReal_lt_trans : forall x y z : CReal, x < y -> y < z -> x < z. Proof. - intros. apply (CRealLt_Le_trans _ y _ H). + intros. apply (CReal_lt_le_trans _ y _ H). apply CRealLt_asym. exact H0. -Qed. +Defined. Lemma CRealEq_trans : forall x y z : CReal, CRealEq x y -> CRealEq y z -> CRealEq x z. @@ -776,6 +774,7 @@ Defined. Notation "0" := (inject_Q 0) : CReal_scope. Notation "1" := (inject_Q 1) : CReal_scope. +Notation "2" := (inject_Q 2) : CReal_scope. Lemma CRealLt_0_1 : CRealLt (inject_Q 0) (inject_Q 1). Proof. @@ -859,6 +858,56 @@ Proof. apply Pos.le_max_r. apply le_refl. Qed. +Lemma inject_Q_compare : forall (x : CReal) (p : positive), + x <= inject_Q (proj1_sig x (Pos.to_nat p) + (1#p)). +Proof. + intros. intros [n nmaj]. + destruct x as [xn xcau]; simpl in nmaj. + apply (Qplus_lt_l _ _ (1#p)) in nmaj. + 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. + 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. + 2: apply Qle_Qabs. + apply (Qlt_trans _ _ _ nmaj) in xcau. + apply (Qplus_lt_l _ _ (-(1#p))) in xcau. ring_simplify in xcau. discriminate. +Qed. + + +Add Parametric Morphism : inject_Q + with signature Qeq ==> CRealEq + as inject_Q_morph. +Proof. + split. + - intros [n abs]. simpl in abs. rewrite H in abs. + unfold Qminus in abs. rewrite Qplus_opp_r in abs. discriminate abs. + - intros [n abs]. simpl in abs. rewrite H in abs. + unfold Qminus in abs. rewrite Qplus_opp_r in abs. discriminate abs. +Qed. + +Instance inject_Q_morph_T + : CMorphisms.Proper + (CMorphisms.respectful Qeq CRealEq) inject_Q. +Proof. + split. + - intros [n abs]. simpl in abs. rewrite H in abs. + unfold Qminus in abs. rewrite Qplus_opp_r in abs. discriminate abs. + - intros [n abs]. simpl in abs. rewrite H in abs. + unfold Qminus in abs. rewrite Qplus_opp_r in abs. discriminate abs. +Qed. + + (* Algebraic operations *) @@ -1029,9 +1078,7 @@ Proof. Qed. Lemma CReal_plus_lt_compat_l : - forall x y z : CReal, - CRealLt y z - -> CRealLt (CReal_plus x y) (CReal_plus x z). + forall x y z : CReal, y < z -> x + y < x + z. Proof. intros. apply CRealLt_above in H. destruct H as [n maj]. @@ -1047,6 +1094,13 @@ Proof. simpl; ring. Qed. +Lemma CReal_plus_lt_compat_r : + forall x y z : CReal, y < z -> y + x < z + x. +Proof. + intros. do 2 rewrite <- (CReal_plus_comm x). + apply CReal_plus_lt_compat_l. assumption. +Qed. + Lemma CReal_plus_lt_reg_l : forall x y z : CReal, x + y < x + z -> y < z. Proof. @@ -1068,6 +1122,20 @@ Proof. apply CReal_plus_lt_reg_l in H. exact H. Qed. +Lemma CReal_plus_le_reg_l : + forall x y z : CReal, x + y <= x + z -> y <= z. +Proof. + intros. intro abs. apply H. clear H. + apply CReal_plus_lt_compat_l. exact abs. +Qed. + +Lemma CReal_plus_le_reg_r : + forall x y z : CReal, y + x <= z + x -> y <= z. +Proof. + intros. intro abs. apply H. clear H. + apply CReal_plus_lt_compat_r. exact abs. +Qed. + Lemma CReal_plus_le_compat_l : forall r r1 r2, r1 <= r2 -> r + r1 <= r + r2. Proof. intros. intro abs. apply CReal_plus_lt_reg_l in abs. contradiction. @@ -1076,12 +1144,21 @@ Qed. Lemma CReal_plus_le_lt_compat : forall r1 r2 r3 r4 : CReal, r1 <= r2 -> r3 < r4 -> r1 + r3 < r2 + r4. Proof. - intros; apply CRealLe_Lt_trans with (r2 + r3). + intros; apply CReal_le_lt_trans with (r2 + r3). intro abs. rewrite CReal_plus_comm, (CReal_plus_comm r1) in abs. apply CReal_plus_lt_reg_l in abs. contradiction. apply CReal_plus_lt_compat_l; exact H0. Qed. +Lemma CReal_plus_le_compat : + forall r1 r2 r3 r4 : CReal, r1 <= r2 -> r3 <= r4 -> r1 + r3 <= r2 + r4. +Proof. + intros; apply CReal_le_trans with (r2 + r3). + intro abs. rewrite CReal_plus_comm, (CReal_plus_comm r1) in abs. + apply CReal_plus_lt_reg_l in abs. contradiction. + apply CReal_plus_le_compat_l; exact H0. +Qed. + Lemma CReal_plus_opp_r : forall x : CReal, x + - x == 0. Proof. @@ -1140,1812 +1217,110 @@ Proof. Qed. Lemma CReal_plus_eq_reg_l : forall (r r1 r2 : CReal), - CRealEq (CReal_plus r r1) (CReal_plus r r2) - -> CRealEq r1 r2. + r + r1 == r + r2 -> r1 == r2. Proof. intros. destruct H. split. - intro abs. apply (CReal_plus_lt_compat_l r) in abs. contradiction. - intro abs. apply (CReal_plus_lt_compat_l r) in abs. contradiction. Qed. -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) - : 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. -Qed. - -Lemma CReal_mult_cauchy - : forall (xn yn zn : nat -> Q) (Ay Az : positive) (cvmod : positive -> nat), - 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)). -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. - apply (Qle_lt_trans _ (Qabs ((xn p - yn q) * zn p) - + Qabs (yn q * (zn p - zn q)))). - apply Qabs_triangle. rewrite Qabs_Qmult. rewrite Qabs_Qmult. - setoid_replace (1#k)%Q with ((1#2*k) + (1#2*k))%Q. - 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. - + 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 (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)). - 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. - - 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. - + 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 Qle_lteq. left. - apply Qmult_lt_l. unfold Qlt. simpl. unfold Z.lt. auto. - apply (Qle_lt_trans _ (Qabs (yn q)%nat * (1 # Ay))). - 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)). - 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. - - 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. -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). - intros p n k H0 H1. - apply H; 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. -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). - 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. -Qed. - -Lemma CReal_mult_assoc_bounded_r : forall (xn yn zn : nat -> Q), - QSeqEquivEx xn yn (* both are Cauchy with same limit *) - -> QSeqEquiv zn zn Pos.to_nat - -> 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. -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)). -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). - 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). - 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) - 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. -Qed. - -Lemma CReal_mult_comm : forall x y : CReal, - CRealEq (CReal_mult x y) (CReal_mult 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. - 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. -Qed. - -(* Axiom Rmult_eq_compat_l *) -Lemma CReal_mult_proper_l : forall x y z : CReal, - CRealEq y z -> CRealEq (CReal_mult x y) (CReal_mult x z). -Proof. - intros. apply CRealEq_diff. apply CRealEq_modindep. - apply (QSeqEquivEx_trans _ (fun n => proj1_sig x n * proj1_sig y n)%Q). - apply CReal_mult_unfold. - rewrite CRealEq_diff in H. rewrite <- CRealEq_modindep in H. - apply QSeqEquivEx_sym. - 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). - 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). - setoid_replace (xn n * yn n - xn k * zn k)%Q - with (yn n * xn n - zn k * xn k)%Q. - apply H0. ring. -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). -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)))). - exists (Pos.max x0 x~0 * Pos.max x1 x2~0)%positive. - simpl. unfold Qminus. rewrite Qplus_0_r. - rewrite <- Pos2Nat.inj_mul. - 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. } - 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))). - unfold Qlt; simpl. assert (forall p : positive, (Z.pos p < Z.pos p~0)%Z). - intro p. rewrite <- (Z.mul_1_l (Z.pos p)). - 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 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. - rewrite <- Pos.mul_assoc. rewrite Pos2Nat.inj_mul. - rewrite <- (mult_1_r (Pos.to_nat (Pos.max x0 x~0))). - rewrite <- mult_assoc. apply Nat.mul_le_mono_nonneg. - apply le_0_n. apply le_refl. auto. - rewrite mult_1_l. apply Pos2Nat.is_pos. -Qed. - -Lemma CReal_mult_plus_distr_l : forall r1 r2 r3 : CReal, - r1 * (r2 + r3) == (r1 * r2) + (r1 * r3). -Proof. - intros x y z. apply CRealEq_diff. apply CRealEq_modindep. - apply (QSeqEquivEx_trans _ (fun n => proj1_sig x n - * (proj1_sig (CReal_plus y z) n))%Q). - 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)) - ; 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 - (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)))). - 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. - 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. - - 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)))). - 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. - 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 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 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. - + rewrite Qinv_plus_distr. unfold Qeq. reflexivity. -Qed. - -Lemma CReal_mult_plus_distr_r : forall r1 r2 r3 : CReal, - (r2 + r3) * r1 == (r2 * r1) + (r3 * r1). -Proof. - intros. - rewrite CReal_mult_comm, CReal_mult_plus_distr_l, - <- (CReal_mult_comm r1), <- (CReal_mult_comm r1). - reflexivity. -Qed. - -Lemma CReal_mult_1_l : forall r: CReal, 1 * r == r. -Proof. - intros [rn limr]. split. - - 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. - 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 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 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). - 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 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_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. - discriminate. apply Z.le_refl. -Qed. - -Lemma CReal_isRingExt : ring_eq_ext CReal_plus CReal_mult CReal_opp CRealEq. -Proof. - split. - - intros x y H z t H0. apply CReal_plus_morph; assumption. - - intros x y H z t H0. apply (CRealEq_trans _ (CReal_mult x t)). - apply CReal_mult_proper_l. apply H0. - apply (CRealEq_trans _ (CReal_mult t x)). apply CReal_mult_comm. - apply (CRealEq_trans _ (CReal_mult t y)). - apply CReal_mult_proper_l. apply H. apply CReal_mult_comm. - - intros x y H. apply (CReal_plus_eq_reg_l x). - apply (CRealEq_trans _ (inject_Q 0)). apply CReal_plus_opp_r. - apply (CRealEq_trans _ (CReal_plus y (CReal_opp y))). - apply CRealEq_sym. apply CReal_plus_opp_r. - apply CReal_plus_proper_r. apply CRealEq_sym. apply H. -Qed. - -Lemma CReal_isRing : ring_theory (inject_Q 0) (inject_Q 1) - CReal_plus CReal_mult - CReal_minus CReal_opp - CRealEq. -Proof. - intros. split. - - apply CReal_plus_0_l. - - apply CReal_plus_comm. - - intros x y z. symmetry. apply CReal_plus_assoc. - - apply CReal_mult_1_l. - - apply CReal_mult_comm. - - intros x y z. symmetry. apply CReal_mult_assoc. - - intros x y z. rewrite <- (CReal_mult_comm z). - rewrite CReal_mult_plus_distr_l. - apply (CRealEq_trans _ (CReal_plus (CReal_mult x z) (CReal_mult z y))). - apply CReal_plus_proper_r. apply CReal_mult_comm. - apply CReal_plus_proper_l. apply CReal_mult_comm. - - intros x y. apply CRealEq_refl. - - apply CReal_plus_opp_r. -Qed. - -Add Parametric Morphism : CReal_mult - with signature CRealEq ==> CRealEq ==> CRealEq - as CReal_mult_morph. -Proof. - apply CReal_isRingExt. -Qed. - -Instance CReal_mult_morph_T - : CMorphisms.Proper - (CMorphisms.respectful CRealEq (CMorphisms.respectful CRealEq CRealEq)) CReal_mult. -Proof. - apply CReal_isRingExt. -Qed. - -Add Parametric Morphism : CReal_opp - with signature CRealEq ==> CRealEq - as CReal_opp_morph. -Proof. - apply (Ropp_ext CReal_isRingExt). -Qed. - -Instance CReal_opp_morph_T - : CMorphisms.Proper - (CMorphisms.respectful CRealEq CRealEq) CReal_opp. -Proof. - apply CReal_isRingExt. -Qed. - -Add Parametric Morphism : CReal_minus - with signature CRealEq ==> CRealEq ==> CRealEq - as CReal_minus_morph. -Proof. - intros. unfold CReal_minus. rewrite H,H0. reflexivity. -Qed. - -Instance CReal_minus_morph_T - : CMorphisms.Proper - (CMorphisms.respectful CRealEq (CMorphisms.respectful CRealEq CRealEq)) CReal_minus. -Proof. - intros x y exy z t ezt. unfold CReal_minus. rewrite exy,ezt. reflexivity. -Qed. - -Add Ring CRealRing : CReal_isRing. - Lemma CReal_opp_0 : -0 == 0. Proof. - ring. + apply (CReal_plus_eq_reg_l 0). + rewrite CReal_plus_0_r, CReal_plus_opp_r. reflexivity. Qed. Lemma CReal_opp_plus_distr : forall r1 r2, - (r1 + r2) == - r1 + - r2. Proof. - intros; ring. + intros. apply (CReal_plus_eq_reg_l (r1+r2)). + rewrite CReal_plus_opp_r, (CReal_plus_comm (-r1)), CReal_plus_assoc. + rewrite <- (CReal_plus_assoc r2), CReal_plus_opp_r, CReal_plus_0_l. + rewrite CReal_plus_opp_r. reflexivity. Qed. Lemma CReal_opp_involutive : forall x:CReal, --x == x. Proof. - intro x. ring. + intros. apply (CReal_plus_eq_reg_l (-x)). + rewrite CReal_plus_opp_l, CReal_plus_opp_r. reflexivity. Qed. Lemma CReal_opp_gt_lt_contravar : forall r1 r2, r1 > r2 -> - r1 < - r2. Proof. unfold CRealGt; intros. apply (CReal_plus_lt_reg_l (r2 + r1)). - setoid_replace (r2 + r1 + - r1) with r2 by ring. - setoid_replace (r2 + r1 + - r2) with r1 by ring. - exact H. -Qed. - -(**********) -Lemma CReal_mult_0_l : forall r, 0 * r == 0. -Proof. - intro; ring. -Qed. - -Lemma CReal_mult_0_r : forall r, r * 0 == 0. -Proof. - intro; ring. -Qed. - -(**********) -Lemma CReal_mult_1_r : forall r, r * 1 == r. -Proof. - intro; ring. -Qed. - -Lemma CReal_opp_mult_distr_l - : forall r1 r2 : CReal, CRealEq (CReal_opp (CReal_mult r1 r2)) - (CReal_mult (CReal_opp r1) r2). -Proof. - intros. ring. + rewrite CReal_plus_assoc, CReal_plus_opp_r, CReal_plus_0_r. + rewrite CReal_plus_comm, <- CReal_plus_assoc, CReal_plus_opp_l. + rewrite CReal_plus_0_l. exact H. Qed. -Lemma CReal_mult_lt_compat_l : forall x y z : CReal, - 0 < x -> y < z -> x*y < x*z. +Lemma CReal_opp_ge_le_contravar : forall r1 r2, r1 >= r2 -> - r1 <= - r2. Proof. - intros. apply (CReal_plus_lt_reg_l - (CReal_opp (CReal_mult x y))). - rewrite CReal_plus_comm. pose proof CReal_plus_opp_r. - unfold CReal_minus in H1. rewrite H1. - rewrite CReal_mult_comm, CReal_opp_mult_distr_l, CReal_mult_comm. - rewrite <- CReal_mult_plus_distr_l. - apply CReal_mult_lt_0_compat. exact H. - apply (CReal_plus_lt_reg_l y). - rewrite CReal_plus_comm, CReal_plus_0_l. - rewrite <- CReal_plus_assoc, H1, CReal_plus_0_l. exact H0. + intros. intro abs. apply H. clear H. + apply (CReal_plus_lt_reg_r (-r1-r2)). + unfold CReal_minus. rewrite <- CReal_plus_assoc, CReal_plus_opp_r, CReal_plus_0_l. + rewrite (CReal_plus_comm (-r1)), <- CReal_plus_assoc, CReal_plus_opp_r, CReal_plus_0_l. + exact abs. Qed. -Lemma CReal_mult_lt_compat_r : forall x y z : CReal, - 0 < x -> y < z -> y*x < z*x. +Lemma inject_Q_plus : forall q r : Q, + inject_Q (q + r) == inject_Q q + inject_Q r. Proof. - intros. rewrite <- (CReal_mult_comm x), <- (CReal_mult_comm x). - apply (CReal_mult_lt_compat_l x); assumption. -Qed. - -Lemma CReal_mult_eq_reg_l : forall (r r1 r2 : CReal), - r # 0 - -> CRealEq (CReal_mult r r1) (CReal_mult r r2) - -> CRealEq r1 r2. -Proof. - intros. destruct H; split. - - intro abs. apply (CReal_mult_lt_compat_l (-r)) in abs. - rewrite <- CReal_opp_mult_distr_l, <- CReal_opp_mult_distr_l, H0 in abs. - exact (CRealLt_irrefl _ abs). apply (CReal_plus_lt_reg_l r). - rewrite CReal_plus_opp_r, CReal_plus_comm, CReal_plus_0_l. exact c. - - intro abs. apply (CReal_mult_lt_compat_l (-r)) in abs. - rewrite <- CReal_opp_mult_distr_l, <- CReal_opp_mult_distr_l, H0 in abs. - exact (CRealLt_irrefl _ abs). apply (CReal_plus_lt_reg_l r). - rewrite CReal_plus_opp_r, CReal_plus_comm, CReal_plus_0_l. exact c. - - intro abs. apply (CReal_mult_lt_compat_l r) in abs. rewrite H0 in abs. - exact (CRealLt_irrefl _ abs). exact c. - - intro abs. apply (CReal_mult_lt_compat_l r) in abs. rewrite H0 in abs. - exact (CRealLt_irrefl _ abs). exact c. -Qed. - - - -(*********************************************************) -(** * Field *) -(*********************************************************) - -(**********) -Fixpoint INR (n:nat) : CReal := - match n with - | O => 0 - | S O => 1 - | S n => INR n + 1 - end. -Arguments INR n%nat. - -(* compact representation for 2*p *) -Fixpoint IPR_2 (p:positive) : CReal := - match p with - | xH => 1 + 1 - | xO p => IPR_2 p + IPR_2 p - | xI p => (1 + IPR_2 p) + (1 + IPR_2 p) - end. - -Definition IPR (p:positive) : CReal := - match p with - | xH => 1 - | xO p => IPR_2 p - | xI p => 1 + IPR_2 p - end. -Arguments IPR p%positive : simpl never. - -(**********) -Definition IZR (z:Z) : CReal := - match z with - | Z0 => 0 - | Zpos n => IPR n - | Zneg n => - IPR n - end. -Arguments IZR z%Z : simpl never. - -Notation "2" := (IZR 2) : CReal_scope. - -(**********) -Lemma S_INR : forall n:nat, INR (S n) == INR n + 1. -Proof. - intro; destruct n. rewrite CReal_plus_0_l. reflexivity. reflexivity. -Qed. - -Lemma le_succ_r_T : forall n m : nat, (n <= S m)%nat -> {(n <= m)%nat} + {n = S m}. -Proof. - intros. destruct (le_lt_dec n m). left. exact l. - right. apply Nat.le_succ_r in H. destruct H. - exfalso. apply (le_not_lt n m); assumption. exact H. -Qed. - -Lemma lt_INR : forall n m:nat, (n < m)%nat -> INR n < INR m. -Proof. - induction m. - - intros. exfalso. inversion H. - - intros. unfold lt in H. apply le_S_n in H. destruct m. - assert (n = 0)%nat. - { inversion H. reflexivity. } - subst n. apply CRealLt_0_1. apply le_succ_r_T in H. destruct H. - rewrite S_INR. apply (CRealLt_trans _ (INR (S m) + 0)). - rewrite CReal_plus_comm, CReal_plus_0_l. apply IHm. - apply le_n_S. exact l. - apply CReal_plus_lt_compat_l. exact CRealLt_0_1. - subst n. rewrite (S_INR (S m)). rewrite <- (CReal_plus_0_l). - rewrite (CReal_plus_comm 0), CReal_plus_assoc. - apply CReal_plus_lt_compat_l. rewrite CReal_plus_0_l. - exact CRealLt_0_1. -Qed. - -(**********) -Lemma S_O_plus_INR : forall n:nat, INR (1 + n) == INR 1 + INR n. -Proof. - intros; destruct n. - - rewrite CReal_plus_comm, CReal_plus_0_l. reflexivity. - - rewrite CReal_plus_comm. reflexivity. -Qed. - -(**********) -Lemma plus_INR : forall n m:nat, INR (n + m) == INR n + INR m. -Proof. - intros n m; induction n as [| n Hrecn]. - - rewrite CReal_plus_0_l. reflexivity. - - replace (S n + m)%nat with (S (n + m)); auto with arith. - repeat rewrite S_INR. - rewrite Hrecn; ring. -Qed. - -(**********) -Lemma minus_INR : forall n m:nat, (m <= n)%nat -> INR (n - m) == INR n - INR m. -Proof. - intros n m le; pattern m, n; apply le_elim_rel. - intros. rewrite <- minus_n_O. unfold CReal_minus. - unfold INR. ring. - intros; repeat rewrite S_INR; simpl. - unfold CReal_minus. rewrite H0. ring. exact le. -Qed. - -(*********) -Lemma mult_INR : forall n m:nat, INR (n * m) == INR n * INR m. -Proof. - intros n m; induction n as [| n Hrecn]. - - rewrite CReal_mult_0_l. reflexivity. - - intros; repeat rewrite S_INR; simpl. - rewrite plus_INR. rewrite Hrecn; ring. -Qed. - -(**********) -Lemma IZN : forall n:Z, (0 <= n)%Z -> { m : nat | n = Z.of_nat m }. -Proof. - intros. exists (Z.to_nat n). rewrite Z2Nat.id. reflexivity. assumption. -Qed. - -Lemma INR_IPR : forall p, INR (Pos.to_nat p) == IPR p. -Proof. - assert (H: forall p, INR (Pos.to_nat p) + INR (Pos.to_nat p) == IPR_2 p). - { induction p as [p|p|]. - - unfold IPR_2; rewrite Pos2Nat.inj_xI, S_INR, mult_INR, <- IHp. - setoid_replace (INR 2) with (1 + 1). 2: reflexivity. ring. - - unfold IPR_2; rewrite Pos2Nat.inj_xO, mult_INR, <- IHp. - setoid_replace (INR 2) with (1 + 1). 2: reflexivity. ring. - - reflexivity. } - intros [p|p|] ; unfold IPR. - rewrite Pos2Nat.inj_xI, S_INR, mult_INR, <- H. - setoid_replace (INR 2) with (1 + 1). 2: reflexivity. ring. - rewrite Pos2Nat.inj_xO, mult_INR, <- H. - setoid_replace (INR 2) with (1 + 1). 2: reflexivity. ring. - easy. -Qed. - -(* This is stronger than Req to injectQ, because it - concerns all the rational sequence, not only its limit. *) -Lemma FinjectP2_CReal : forall (p:positive) (k:nat), - (proj1_sig (IPR_2 p) k == Z.pos p~0 # 1)%Q. -Proof. - induction p. - - intros. replace (IPR_2 p~1) with (1 + IPR_2 p + (1+ IPR_2 p)). - 2: reflexivity. do 2 rewrite CReal_plus_nth. rewrite IHp. - simpl. rewrite Pos2Z.inj_xO, (Pos2Z.inj_xO (p~1)), Pos2Z.inj_xI. - generalize (2*Z.pos p)%Z. intro z. - do 2 rewrite Qinv_plus_distr. apply f_equal2. - 2: reflexivity. unfold Qnum. ring. - - intros. replace (IPR_2 p~0) with (IPR_2 p + IPR_2 p). - 2: reflexivity. rewrite CReal_plus_nth, IHp. - rewrite Qinv_plus_distr. apply f_equal2. 2: reflexivity. - unfold Qnum. rewrite (Pos2Z.inj_xO (p~0)). ring. - - intros. reflexivity. -Qed. - -Lemma FinjectP_CReal : forall (p:positive) (k:nat), - (proj1_sig (IPR p) k == Z.pos p # 1)%Q. -Proof. - destruct p. - - intros. unfold IPR. - rewrite CReal_plus_nth, FinjectP2_CReal. unfold Qeq; simpl. - rewrite Pos.mul_1_r. reflexivity. - - intros. unfold IPR. rewrite FinjectP2_CReal. reflexivity. - - intros. reflexivity. -Qed. - -(* Inside this Cauchy real implementation, we can give - an instantaneous witness of this inequality, because - we know a priori that it will work. *) -Lemma IPR_pos : forall p:positive, 0 < IPR p. -Proof. - intro p. exists 3%positive. simpl. - rewrite FinjectP_CReal. apply (Qlt_le_trans _ 1). reflexivity. - unfold Qle; simpl. - rewrite <- (Zpos_max_1 (p*1*1)). apply Z.le_max_l. -Defined. - -Lemma IPR_double : forall p:positive, IPR (2*p) == 2 * IPR p. -Proof. - intro p. - destruct p; rewrite (CReal_mult_plus_distr_r _ 1 1), CReal_mult_1_l; reflexivity. -Qed. - -(**********) -Lemma INR_IZR_INZ : forall n:nat, INR n == IZR (Z.of_nat n). -Proof. - intros [|n]. - easy. - simpl Z.of_nat. unfold IZR. - now rewrite <- INR_IPR, SuccNat2Pos.id_succ. -Qed. - -Lemma plus_IZR_NEG_POS : - forall p q:positive, IZR (Zpos p + Zneg q) == IZR (Zpos p) + IZR (Zneg q). -Proof. - intros p q; simpl. rewrite Z.pos_sub_spec. - case Pos.compare_spec; intros H; unfold IZR. - subst. ring. - rewrite <- 3!INR_IPR, Pos2Nat.inj_sub. - rewrite minus_INR. - 2: (now apply lt_le_weak, Pos2Nat.inj_lt). - ring. - trivial. - rewrite <- 3!INR_IPR, Pos2Nat.inj_sub. - rewrite minus_INR. - 2: (now apply lt_le_weak, Pos2Nat.inj_lt). - ring. trivial. -Qed. - -Lemma plus_IPR : forall n m:positive, IPR (n + m) == IPR n + IPR m. -Proof. - intros. repeat rewrite <- INR_IPR. - rewrite Pos2Nat.inj_add. apply plus_INR. -Qed. - -(**********) -Lemma plus_IZR : forall n m:Z, IZR (n + m) == IZR n + IZR m. -Proof. - intro z; destruct z; intro t; destruct t; intros. - - rewrite CReal_plus_0_l. reflexivity. - - rewrite CReal_plus_0_l. rewrite Z.add_0_l. reflexivity. - - rewrite CReal_plus_0_l. reflexivity. - - rewrite CReal_plus_comm,CReal_plus_0_l. reflexivity. - - rewrite <- Pos2Z.inj_add. unfold IZR. apply plus_IPR. - - apply plus_IZR_NEG_POS. - - rewrite CReal_plus_comm,CReal_plus_0_l, Z.add_0_r. reflexivity. - - rewrite Z.add_comm; rewrite CReal_plus_comm; apply plus_IZR_NEG_POS. - - simpl. unfold IZR. rewrite <- 3!INR_IPR, Pos2Nat.inj_add, plus_INR. - ring. -Qed. - -Lemma mult_IPR : forall n m:positive, IPR (n * m) == IPR n * IPR m. -Proof. - intros. repeat rewrite <- INR_IPR. - rewrite Pos2Nat.inj_mul. apply mult_INR. -Qed. - -Lemma mult_IZR : forall n m:Z, IZR (n * m) == IZR n * IZR m. -Proof. - intros n m. destruct n. - - rewrite CReal_mult_0_l. rewrite Z.mul_0_l. reflexivity. - - destruct m. rewrite Z.mul_0_r, CReal_mult_0_r. reflexivity. - simpl; unfold IZR. apply mult_IPR. - simpl. unfold IZR. rewrite mult_IPR. ring. - - destruct m. rewrite Z.mul_0_r, CReal_mult_0_r. reflexivity. - simpl. unfold IZR. rewrite mult_IPR. ring. - simpl. unfold IZR. rewrite mult_IPR. ring. -Qed. - -Lemma opp_IZR : forall n:Z, IZR (- n) == - IZR n. -Proof. - intros [|z|z]; unfold IZR. rewrite CReal_opp_0. reflexivity. - reflexivity. rewrite CReal_opp_involutive. reflexivity. -Qed. - -Lemma minus_IZR : forall n m:Z, IZR (n - m) == IZR n - IZR m. -Proof. - intros; unfold Z.sub, CReal_minus. - rewrite <- opp_IZR. - apply plus_IZR. -Qed. - -Lemma IZR_lt : forall n m:Z, (n < m)%Z -> IZR n < IZR m. -Proof. - assert (forall n:Z, Z.lt 0 n -> 0 < IZR n) as posCase. - { intros. destruct (IZN n). apply Z.lt_le_incl. apply H. - subst n. rewrite <- INR_IZR_INZ. apply (lt_INR 0). - apply Nat2Z.inj_lt. apply H. } - intros. apply (CReal_plus_lt_reg_r (-(IZR n))). - pose proof minus_IZR. unfold CReal_minus in H0. - repeat rewrite <- H0. unfold Zminus. - rewrite Z.add_opp_diag_r. apply posCase. - rewrite (Z.add_lt_mono_l _ _ n). ring_simplify. apply H. -Qed. - -Lemma Z_R_minus : forall n m:Z, IZR n - IZR m == IZR (n - m). -Proof. - intros z1 z2; unfold CReal_minus; unfold Z.sub. - rewrite plus_IZR, opp_IZR. reflexivity. -Qed. - -Lemma lt_0_IZR : forall n:Z, 0 < IZR n -> (0 < n)%Z. -Proof. - intro z; case z; simpl; intros. - elim (CRealLt_irrefl _ H). - easy. exfalso. - apply (CRealLt_asym 0 (IZR (Z.neg p))). exact H. - apply (IZR_lt (Z.neg p) 0). reflexivity. -Qed. - -Lemma lt_IZR : forall n m:Z, IZR n < IZR m -> (n < m)%Z. -Proof. - intros z1 z2 H; apply Z.lt_0_sub. - apply lt_0_IZR. - rewrite <- Z_R_minus. apply (CReal_plus_lt_reg_l (IZR z1)). - ring_simplify. exact H. -Qed. - -Lemma IZR_le : forall n m:Z, (n <= m)%Z -> IZR n <= IZR m. -Proof. - intros m n H. intro abs. apply (lt_IZR n m) in abs. omega. -Qed. - -Lemma CReal_iterate_one : forall (n : nat), - IZR (Z.of_nat n) == inject_Q (Z.of_nat n # 1). -Proof. - induction n. - - apply CRealEq_refl. - - replace (Z.of_nat (S n)) with (1 + Z.of_nat n)%Z. - rewrite plus_IZR. - rewrite IHn. clear IHn. apply CRealEq_diff. intro k. simpl. - rewrite Z.mul_1_r. rewrite Z.mul_1_r. rewrite Z.mul_1_r. - rewrite Z.add_opp_diag_r. discriminate. - replace (S n) with (1 + n)%nat. 2: reflexivity. - rewrite (Nat2Z.inj_add 1 n). reflexivity. -Qed. - -(* The constant sequences of rationals are CRealEq to - the rational operations on the unity. *) -Lemma FinjectZ_CReal : forall z : Z, - IZR z == inject_Q (z # 1). -Proof. - intros. destruct z. - - apply CRealEq_refl. - - simpl. pose proof (CReal_iterate_one (Pos.to_nat p)). - rewrite positive_nat_Z in H. apply H. - - simpl. apply (CReal_plus_eq_reg_l (IZR (Z.pos p))). - pose proof CReal_plus_opp_r. rewrite H. - pose proof (CReal_iterate_one (Pos.to_nat p)). - rewrite positive_nat_Z in H0. rewrite H0. - apply CRealEq_diff. intro n. simpl. rewrite Z.pos_sub_diag. - discriminate. -Qed. - - -(* Axiom Rarchimed_constr *) -Lemma Rarchimedean - : forall x:CReal, - { n:Z & x < IZR n < x+2 }. -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. - exists (n+1)%Z. split. - - rewrite FinjectZ_CReal. - assert (Qlt 0 ((n + 1 # 1) - (xn 4%nat + (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]. - exists (Pos.max 4 k). simpl. - apply (Qlt_trans _ ((n + 1 # 1) - (xn 4%nat + (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. - 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))). - ring_simplify. - apply (Qle_lt_trans _ (Qabs (xn (Pos.to_nat (Pos.max 4 k)) - xn 4%nat))). - apply Qle_Qabs. apply limx. - rewrite Pos2Nat.inj_max. apply Nat.le_max_l. apply le_refl. - - apply (CReal_plus_lt_reg_l (-IZR 2)). ring_simplify. - do 2 rewrite FinjectZ_CReal. - 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). - unfold Pos.to_nat; simpl. - rewrite <- (Qplus_lt_r _ _ (-xn 4%nat)). ring_simplify. - reflexivity. -Qed. - -Lemma CRealLtDisjunctEpsilon : forall a b c d : CReal, - (CRealLtProp a b \/ CRealLtProp c d) -> CRealLt a b + CRealLt c d. -Proof. - intros. - 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))). - { 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. - destruct H as [n maj]. exists (Pos.to_nat n). split. - intro abs. destruct (Pos2Nat.is_succ n). rewrite H in abs. - inversion abs. right. rewrite Pos2Nat.id. apply maj. } - 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. - 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. - - 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))). - 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))). - 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. - apply (Qlt_not_le (2 # Pos.of_nat (S n)) - (proj1_sig d (S n) - proj1_sig c (S n))); assumption. -Qed. - -Lemma CRealShiftReal : forall (x : CReal) (k : nat), - QCauchySeq (fun n => proj1_sig x (plus n k)) Pos.to_nat. -Proof. - intros x k n p q H H0. - 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. -Qed. - -Lemma CRealShiftEqual : forall (x : CReal) (k : nat), - CRealEq x (exist _ (fun n => proj1_sig x (plus 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)). - 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_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. - - intros [n maj]. destruct x as [xn cau]; simpl in maj. - specialize (cau n (Pos.to_nat n) (Pos.to_nat n + k)%nat). - 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_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 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) }. -Proof. - intro xNeg. - pose proof (CRealLt_aboveSig x (inject_Q 0)). - pose proof (CRealShiftReal x). - 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 _]. - 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)))). - 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. -Qed. - -Definition CRealPosShift (x : CReal) - : CRealLt (inject_Q 0) x - -> { y : prod positive CReal | CRealEq x (snd y) - /\ forall n:nat, Qlt (1 # fst y) (proj1_sig (snd y) n) }. -Proof. - intro xPos. - pose proof (CRealLt_aboveSig (inject_Q 0) x). - pose proof (CRealShiftReal x). - 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 _]. - 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)))). - 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. -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. -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) - / (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. - { 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 Qmult_lt_l. reflexivity. rewrite Qabs_neg. - specialize (maj (Pos.to_nat k * (Pos.to_nat k * 1) * p)%nat). - 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 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). - 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. - rewrite Qabs_neg. - specialize (maj (Pos.to_nat k * (Pos.to_nat k * 1) * q)%nat). - 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. } - unfold Qdiv. rewrite Qabs_Qmult. rewrite Qabs_Qinv. - rewrite Qmult_comm. rewrite <- (Qmult_comm (/ (1 # k ^ 2))). - apply Qmult_le_compat_r. apply Qlt_le_weak. - rewrite <- Qmult_1_l. apply Qlt_shift_div_r. - apply (Qlt_trans 0 (1 # k ^ 2)). reflexivity. apply H. - rewrite Qmult_comm. apply Qlt_shift_div_l. - 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). - 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 factorDenom. apply Qle_refl. - + field. split. intro abs. - specialize (maj (Pos.to_nat k ^ 2 * p)%nat). - rewrite abs in maj. inversion maj. - intro abs. - specialize (maj (Pos.to_nat k ^ 2 * q)%nat). - 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. -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) - / (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. - { 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 Qmult_lt_l. reflexivity. rewrite Qabs_pos. - specialize (maj (Pos.to_nat k * (Pos.to_nat k * 1) * p)%nat). - 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). - 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). - apply maj. apply (Qle_trans _ (1 # k)). discriminate. - apply Zlt_le_weak. apply maj. } - unfold Qdiv. rewrite Qabs_Qmult. rewrite Qabs_Qinv. - rewrite Qmult_comm. rewrite <- (Qmult_comm (/ (1 # k ^ 2))). - apply Qmult_le_compat_r. apply Qlt_le_weak. - rewrite <- Qmult_1_l. apply Qlt_shift_div_r. - apply (Qlt_trans 0 (1 # k ^ 2)). reflexivity. apply H. - rewrite Qmult_comm. apply Qlt_shift_div_l. - 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). - 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 factorDenom. apply Qle_refl. - + field. split. intro abs. - specialize (maj (Pos.to_nat k ^ 2 * p)%nat). - rewrite abs in maj. inversion maj. - intro abs. - specialize (maj (Pos.to_nat k ^ 2 * q)%nat). - rewrite abs in maj. inversion maj. -Qed. - -Definition CReal_inv (x : CReal) (xnz : x # 0) : CReal. -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))). - 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))). - apply (CReal_inv_pos yn). apply cau. apply maj. -Defined. - -Notation "/ x" := (CReal_inv x) (at level 35, right associativity) : CReal_scope. - -Lemma CReal_inv_0_lt_compat - : forall (r : CReal) (rnz : r # 0), - 0 < r -> 0 < ((/ r) rnz). -Proof. - intros. unfold CReal_inv. simpl. - destruct rnz. - - exfalso. apply CRealLt_asym in H. contradiction. - - 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]. - 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))). - 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))). - apply Qle_Qabs. apply (Qlt_le_trans _ 1). apply cau. - apply Pos2Nat.is_pos. apply 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. - apply Qlt_minus_iff in majA. apply majA. - 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. -Qed. - -Lemma CReal_linear_shift_eq : forall (x : CReal) (k : nat) (kPos : le 1 k), - 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)). -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). - 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. -Qed. - -Lemma CReal_inv_l : forall (r:CReal) (rnz : r # 0), - ((/ r) rnz) * r == 1. -Proof. - intros. unfold CReal_inv; simpl. - destruct rnz. - - (* r < 0 *) destruct (CRealNegShift r c) as [[k rneg] [req maj]]. - simpl in req. apply CRealEq_diff. apply CRealEq_modindep. - apply (QSeqEquivEx_trans _ - (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) - (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 _ - (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)) - (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. - 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 - (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. - 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. - - (* 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)) - (CReal_inv_pos 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 _ - (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)) - (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. - 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 - (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. - 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. -Qed. - -Lemma CReal_inv_r : forall (r:CReal) (rnz : r # 0), - r * ((/ r) rnz) == 1. -Proof. - intros. rewrite CReal_mult_comm, CReal_inv_l. - reflexivity. -Qed. - -Lemma CReal_inv_1 : forall nz : 1 # 0, (/ 1) nz == 1. -Proof. - intros. rewrite <- (CReal_mult_1_l ((/1) nz)). rewrite CReal_inv_r. - reflexivity. -Qed. - -Lemma CReal_inv_mult_distr : - forall r1 r2 (r1nz : r1 # 0) (r2nz : r2 # 0) (rmnz : (r1*r2) # 0), - (/ (r1 * r2)) rmnz == (/ r1) r1nz * (/ r2) r2nz. -Proof. - intros. apply (CReal_mult_eq_reg_l r1). exact r1nz. - rewrite <- CReal_mult_assoc. rewrite CReal_inv_r. rewrite CReal_mult_1_l. - apply (CReal_mult_eq_reg_l r2). exact r2nz. - rewrite CReal_inv_r. rewrite <- CReal_mult_assoc. - rewrite (CReal_mult_comm r2 r1). rewrite CReal_inv_r. - reflexivity. -Qed. - -Lemma Rinv_eq_compat : forall x y (rxnz : x # 0) (rynz : y # 0), - x == y - -> (/ x) rxnz == (/ y) rynz. -Proof. - intros. apply (CReal_mult_eq_reg_l x). exact rxnz. - rewrite CReal_inv_r, H, CReal_inv_r. reflexivity. -Qed. - -Lemma CReal_mult_lt_reg_l : forall r r1 r2, 0 < r -> r * r1 < r * r2 -> r1 < r2. -Proof. - intros z x y H H0. - apply (CReal_mult_lt_compat_l ((/z) (inr H))) in H0. - repeat rewrite <- CReal_mult_assoc in H0. rewrite CReal_inv_l in H0. - repeat rewrite CReal_mult_1_l in H0. apply H0. - apply CReal_inv_0_lt_compat. exact H. -Qed. - -Lemma CReal_mult_lt_reg_r : forall r r1 r2, 0 < r -> r1 * r < r2 * r -> r1 < r2. -Proof. - intros. - apply CReal_mult_lt_reg_l with r. - exact H. - now rewrite 2!(CReal_mult_comm r). -Qed. - -Lemma CReal_mult_eq_reg_r : forall r r1 r2, r1 * r == r2 * r -> r # 0 -> r1 == r2. -Proof. - intros. apply (CReal_mult_eq_reg_l r). exact H0. - now rewrite 2!(CReal_mult_comm r). -Qed. - -Lemma CReal_mult_eq_compat_l : forall r r1 r2, r1 == r2 -> r * r1 == r * r2. -Proof. - intros. rewrite H. reflexivity. -Qed. - -Lemma CReal_mult_eq_compat_r : forall r r1 r2, r1 == r2 -> r1 * r == r2 * r. -Proof. - intros. rewrite H. reflexivity. -Qed. - -Fixpoint pow (r:CReal) (n:nat) : CReal := - match n with - | O => 1 - | S n => r * (pow r n) - end. - - -(**********) -Definition IQR (q:Q) : CReal := - match q with - | Qmake a b => IZR a * (CReal_inv (IPR b)) (inr (IPR_pos b)) - end. -Arguments IQR q%Q : simpl never. - -Lemma mult_IPR_IZR : forall (n:positive) (m:Z), IZR (Z.pos n * m) == IPR n * IZR m. -Proof. - intros. rewrite mult_IZR. apply CReal_mult_eq_compat_r. reflexivity. -Qed. - -Lemma plus_IQR : forall n m:Q, IQR (n + m) == IQR n + IQR m. -Proof. - intros. destruct n,m; unfold Qplus,IQR; simpl. - rewrite plus_IZR. repeat rewrite mult_IZR. - setoid_replace ((/ IPR (Qden * Qden0)) (inr (IPR_pos (Qden * Qden0)))) - with ((/ IPR Qden) (inr (IPR_pos Qden)) - * (/ IPR Qden0) (inr (IPR_pos Qden0))). - rewrite CReal_mult_plus_distr_r. - repeat rewrite CReal_mult_assoc. rewrite <- (CReal_mult_assoc (IZR (Z.pos Qden))). - rewrite CReal_inv_r, CReal_mult_1_l. - rewrite (CReal_mult_comm ((/IPR Qden) (inr (IPR_pos Qden)))). - rewrite <- (CReal_mult_assoc (IZR (Z.pos Qden0))). - rewrite CReal_inv_r, CReal_mult_1_l. reflexivity. unfold IZR. - rewrite <- (CReal_inv_mult_distr - _ _ _ _ (inr (CReal_mult_lt_0_compat _ _ (IPR_pos _) (IPR_pos _)))). - apply Rinv_eq_compat. apply mult_IPR. -Qed. - -Lemma IQR_pos : forall q:Q, Qlt 0 q -> 0 < IQR q. -Proof. - intros. destruct q; unfold IQR. - apply CReal_mult_lt_0_compat. apply (IZR_lt 0). - unfold Qlt in H; simpl in H. - rewrite Z.mul_1_r in H. apply H. - apply CReal_inv_0_lt_compat. apply IPR_pos. + split. + - intros [n nmaj]. simpl in nmaj. + ring_simplify in nmaj. discriminate. + - intros [n nmaj]. simpl in nmaj. + ring_simplify in nmaj. discriminate. Qed. -Lemma opp_IQR : forall q:Q, IQR (- q) == - IQR q. +Lemma inject_Q_one : inject_Q 1 == 1. Proof. - intros [a b]; unfold IQR; simpl. - rewrite CReal_opp_mult_distr_l. - rewrite opp_IZR. reflexivity. + split. + - intros [n nmaj]. simpl in nmaj. + ring_simplify in nmaj. discriminate. + - intros [n nmaj]. simpl in nmaj. + ring_simplify in nmaj. discriminate. Qed. -Lemma lt_IQR : forall n m:Q, IQR n < IQR m -> (n < m)%Q. +Lemma inject_Q_lt : forall q r : Q, + Qlt q r -> inject_Q q < inject_Q r. Proof. - intros. destruct n,m; unfold IQR in H. - unfold Qlt; simpl. apply (CReal_mult_lt_compat_r (IPR Qden)) in H. - rewrite CReal_mult_assoc in H. rewrite CReal_inv_l in H. - rewrite CReal_mult_1_r in H. rewrite (CReal_mult_comm (IZR Qnum0)) in H. - apply (CReal_mult_lt_compat_l (IPR Qden0)) in H. - do 2 rewrite <- CReal_mult_assoc in H. rewrite CReal_inv_r in H. - rewrite CReal_mult_1_l in H. - rewrite (CReal_mult_comm (IZR Qnum0)) in H. - do 2 rewrite <- mult_IPR_IZR in H. apply lt_IZR in H. - rewrite Z.mul_comm. rewrite (Z.mul_comm Qnum0). - apply H. apply IPR_pos. apply IPR_pos. + intros. destruct (Qarchimedean (/(r-q))). + exists (2*x)%positive; simpl. + setoid_replace (2 # x~0)%Q with (/(Z.pos x#1))%Q. 2: reflexivity. + apply Qlt_shift_inv_r. reflexivity. + apply (Qmult_lt_l _ _ (r-q)) in q0. rewrite Qmult_inv_r in q0. + exact q0. intro abs. rewrite Qlt_minus_iff in H. + unfold Qminus in abs. rewrite abs in H. discriminate H. + unfold Qminus. rewrite <- Qlt_minus_iff. exact H. Qed. -Lemma CReal_mult_le_compat_l_half : forall r r1 r2, - 0 < r -> r1 <= r2 -> r * r1 <= r * r2. +Lemma opp_inject_Q : forall q : Q, + inject_Q (-q) == - inject_Q q. Proof. - intros. intro abs. apply (CReal_mult_lt_reg_l) in abs. - contradiction. apply H. + split. + - intros [n maj]. simpl in maj. ring_simplify in maj. discriminate. + - intros [n maj]. simpl in maj. ring_simplify in maj. discriminate. Qed. -Lemma IQR_lt : forall n m:Q, Qlt n m -> IQR n < IQR m. +Lemma lt_inject_Q : forall q r : Q, + inject_Q q < inject_Q r -> Qlt q r. Proof. - intros. apply (CReal_plus_lt_reg_r (-IQR n)). - rewrite CReal_plus_opp_r. rewrite <- opp_IQR. rewrite <- plus_IQR. - apply IQR_pos. apply (Qplus_lt_l _ _ n). - ring_simplify. apply H. + intros. destruct H. simpl in q0. + apply Qlt_minus_iff, (Qlt_trans _ (2#x)). + reflexivity. exact q0. Qed. -Lemma IQR_nonneg : forall q:Q, Qle 0 q -> 0 <= (IQR q). +Lemma le_inject_Q : forall q r : Q, + inject_Q q <= inject_Q r -> Qle q r. Proof. - intros [a b] H. unfold IQR. - apply (CRealLe_trans _ ((/ IPR b) (inr (IPR_pos b)) * 0)). - rewrite CReal_mult_0_r. apply CRealLe_refl. - rewrite (CReal_mult_comm (IZR a)). apply CReal_mult_le_compat_l_half. - apply CReal_inv_0_lt_compat. apply IPR_pos. - apply (IZR_le 0 a). unfold Qle in H; simpl in H. - rewrite Z.mul_1_r in H. apply H. + intros. destruct (Qlt_le_dec r q). 2: exact q0. + exfalso. apply H. clear H. apply inject_Q_lt. exact q0. Qed. -Lemma IQR_le : forall n m:Q, Qle n m -> IQR n <= IQR m. +Lemma inject_Q_le : forall q r : Q, + Qle q r -> inject_Q q <= inject_Q r. Proof. - intros. intro abs. apply (CReal_plus_lt_compat_l (-IQR n)) in abs. - rewrite CReal_plus_opp_l, <- opp_IQR, <- plus_IQR in abs. - apply IQR_nonneg in abs. contradiction. apply (Qplus_le_l _ _ n). - ring_simplify. apply H. + intros. intros [n maj]. simpl in maj. + apply (Qlt_not_le _ _ maj). apply (Qle_trans _ 0). + apply (Qplus_le_l _ _ r). ring_simplify. exact H. discriminate. Qed. - -Add Parametric Morphism : IQR - with signature Qeq ==> CRealEq - as IQR_morph. -Proof. - intros. destruct x,y; unfold IQR. - unfold Qeq in H; simpl in H. - apply (CReal_mult_eq_reg_r (IZR (Z.pos Qden))). - 2: right; apply IPR_pos. - rewrite CReal_mult_assoc. rewrite CReal_inv_l. rewrite CReal_mult_1_r. - rewrite (CReal_mult_comm (IZR Qnum0)). - apply (CReal_mult_eq_reg_l (IZR (Z.pos Qden0))). - right; apply IPR_pos. - rewrite <- CReal_mult_assoc, <- CReal_mult_assoc, CReal_inv_r. - rewrite CReal_mult_1_l. - repeat rewrite <- mult_IZR. - rewrite <- H. rewrite Zmult_comm. reflexivity. -Qed. - -Instance IQR_morph_T - : CMorphisms.Proper - (CMorphisms.respectful Qeq CRealEq) IQR. -Proof. - intros x y H. destruct x,y; unfold IQR. - unfold Qeq in H; simpl in H. - apply (CReal_mult_eq_reg_r (IZR (Z.pos Qden))). - 2: right; apply IPR_pos. - rewrite CReal_mult_assoc. rewrite CReal_inv_l. rewrite CReal_mult_1_r. - rewrite (CReal_mult_comm (IZR Qnum0)). - apply (CReal_mult_eq_reg_l (IZR (Z.pos Qden0))). - right; apply IPR_pos. - rewrite <- CReal_mult_assoc, <- CReal_mult_assoc, CReal_inv_r. - rewrite CReal_mult_1_l. - repeat rewrite <- mult_IZR. - rewrite <- H. rewrite Zmult_comm. reflexivity. -Qed. - -Lemma CReal_invQ : forall (b : positive) (pos : Qlt 0 (Z.pos b # 1)), - CRealEq (CReal_inv (inject_Q (Z.pos b # 1)) (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. - do 2 rewrite Pos.mul_1_r. rewrite Z.pos_sub_diag. discriminate. -Qed. - -(* The constant sequences of rationals are CRealEq to - the rational operations on the unity. *) -Lemma FinjectQ_CReal : forall q : Q, - IQR q == inject_Q q. -Proof. - intros [a b]. unfold IQR. - pose proof (CReal_iterate_one (Pos.to_nat b)). - rewrite positive_nat_Z in H. simpl in H. - assert (0 < Z.pos b # 1)%Q as pos. reflexivity. - apply (CRealEq_trans _ (CReal_mult (IZR a) - (CReal_inv (inject_Q (Z.pos b # 1)) (inr (CReal_injectQPos (Z.pos b # 1) pos))))). - - apply CReal_mult_proper_l. - apply (CReal_mult_eq_reg_l (IPR b)). - right. apply IPR_pos. - rewrite CReal_mult_comm, CReal_inv_l, H, CReal_mult_comm, CReal_inv_l. reflexivity. - - rewrite FinjectZ_CReal. rewrite CReal_invQ. apply CRealEq_diff. intro n. - simpl; - destruct (QCauchySeq_bounded (fun _ : nat => a # 1)%Q Pos.to_nat (ConstCauchy (a # 1))), - (QCauchySeq_bounded (fun _ : nat => 1 # b)%Q Pos.to_nat (ConstCauchy (1 # b))); simpl. - rewrite Z.mul_1_r. rewrite <- Z.mul_add_distr_r. - rewrite Z.add_opp_diag_r. rewrite Z.mul_0_l. simpl. - discriminate. -Qed. - -Lemma CReal_gen_inject : forall (n : nat), - gen_phiZ (inject_Q 0) (inject_Q 1) CReal_plus CReal_mult CReal_opp - (Z.of_nat n) - == inject_Q (Z.of_nat n # 1). -Proof. - induction n. - - apply CRealEq_refl. - - replace (Z.of_nat (S n)) with (1 + Z.of_nat n)%Z. - rewrite (gen_phiZ_add CRealEq_rel CReal_isRingExt CReal_isRing). - rewrite IHn. clear IHn. apply CRealEq_diff. intro k. simpl. - rewrite Z.mul_1_r. rewrite Z.mul_1_r. rewrite Z.mul_1_r. - rewrite Z.add_opp_diag_r. discriminate. - replace (S n) with (1 + n)%nat. 2: reflexivity. - rewrite (Nat2Z.inj_add 1 n). reflexivity. -Qed. - -Lemma CRealArchimedean - : forall x:CReal, { n:Z & CRealLt x (gen_phiZ (inject_Q 0) (inject_Q 1) CReal_plus - CReal_mult CReal_opp n) }. -Proof. - intros [xn limx]. destruct (Qarchimedean (xn 1%nat)) as [k kmaj]. - exists (Z.pos (2 + k)). rewrite <- (positive_nat_Z (2 + k)). - rewrite CReal_gen_inject. rewrite (positive_nat_Z (2 + k)). - exists xH. - setoid_replace (2 # 1)%Q with - ((Z.pos (2 + k) # 1) - (Z.pos k # 1))%Q. - - apply Qplus_lt_r. apply Qlt_minus_iff. rewrite Qopp_involutive. - apply Qlt_minus_iff in kmaj. rewrite Qplus_comm. apply kmaj. - - unfold Qminus. setoid_replace (- (Z.pos k # 1))%Q with (-Z.pos k # 1)%Q. - 2: reflexivity. rewrite Qinv_plus_distr. - rewrite Pos2Z.inj_add. rewrite <- Zplus_assoc. - rewrite Zplus_opp_r. reflexivity. -Qed. - - -Close Scope CReal_scope. - -Close Scope Q. diff --git a/theories/Reals/ConstructiveCauchyRealsMult.v b/theories/Reals/ConstructiveCauchyRealsMult.v new file mode 100644 index 0000000000..d6d4e84560 --- /dev/null +++ b/theories/Reals/ConstructiveCauchyRealsMult.v @@ -0,0 +1,1415 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) +(************************************************************************) + +(* The multiplication and division of Cauchy reals. *) + +Require Import QArith. +Require Import Qabs. +Require Import Qround. +Require Import Logic.ConstructiveEpsilon. +Require Export Reals.ConstructiveCauchyReals. +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) + : 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. +Qed. + +Lemma CReal_mult_cauchy + : forall (xn yn zn : nat -> Q) (Ay Az : positive) (cvmod : positive -> nat), + 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)). +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. + apply (Qle_lt_trans _ (Qabs ((xn p - yn q) * zn p) + + Qabs (yn q * (zn p - zn q)))). + apply Qabs_triangle. rewrite Qabs_Qmult. rewrite Qabs_Qmult. + setoid_replace (1#k)%Q with ((1#2*k) + (1#2*k))%Q. + 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. + + 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 (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)). + 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. + - 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. + + 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 Qle_lteq. left. + apply Qmult_lt_l. unfold Qlt. simpl. unfold Z.lt. auto. + apply (Qle_lt_trans _ (Qabs (yn q)%nat * (1 # Ay))). + 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)). + 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. + - 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. +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). + intros p n k H0 H1. + apply H; 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. +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). + 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. +Qed. + +Lemma CReal_mult_assoc_bounded_r : forall (xn yn zn : nat -> Q), + QSeqEquivEx xn yn (* both are Cauchy with same limit *) + -> QSeqEquiv zn zn Pos.to_nat + -> 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. +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)). +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). + 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). + 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) + 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. +Qed. + +Lemma CReal_mult_comm : forall x y : CReal, + CRealEq (CReal_mult x y) (CReal_mult 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. + 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. +Qed. + +Lemma CReal_mult_proper_l : forall x y z : CReal, + CRealEq y z -> CRealEq (CReal_mult x y) (CReal_mult x z). +Proof. + intros. apply CRealEq_diff. apply CRealEq_modindep. + apply (QSeqEquivEx_trans _ (fun n => proj1_sig x n * proj1_sig y n)%Q). + apply CReal_mult_unfold. + rewrite CRealEq_diff in H. rewrite <- CRealEq_modindep in H. + apply QSeqEquivEx_sym. + 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). + 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). + setoid_replace (xn n * yn n - xn k * zn k)%Q + with (yn n * xn n - zn k * xn k)%Q. + apply H0. ring. +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). +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)))). + exists (Pos.max x0 x~0 * Pos.max x1 x2~0)%positive. + simpl. unfold Qminus. rewrite Qplus_0_r. + rewrite <- Pos2Nat.inj_mul. + 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. } + 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))). + unfold Qlt; simpl. assert (forall p : positive, (Z.pos p < Z.pos p~0)%Z). + intro p. rewrite <- (Z.mul_1_l (Z.pos p)). + 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 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. + rewrite <- Pos.mul_assoc. rewrite Pos2Nat.inj_mul. + rewrite <- (mult_1_r (Pos.to_nat (Pos.max x0 x~0))). + rewrite <- mult_assoc. apply Nat.mul_le_mono_nonneg. + apply le_0_n. apply le_refl. auto. + rewrite mult_1_l. apply Pos2Nat.is_pos. +Qed. + +Lemma CReal_mult_plus_distr_l : forall r1 r2 r3 : CReal, + r1 * (r2 + r3) == (r1 * r2) + (r1 * r3). +Proof. + intros x y z. apply CRealEq_diff. apply CRealEq_modindep. + apply (QSeqEquivEx_trans _ (fun n => proj1_sig x n + * (proj1_sig (CReal_plus y z) n))%Q). + 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)) + ; 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 + (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)))). + 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. + 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. + - 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)))). + 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. + 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 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 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. + + rewrite Qinv_plus_distr. unfold Qeq. reflexivity. +Qed. + +Lemma CReal_mult_plus_distr_r : forall r1 r2 r3 : CReal, + (r2 + r3) * r1 == (r2 * r1) + (r3 * r1). +Proof. + intros. + rewrite CReal_mult_comm, CReal_mult_plus_distr_l, + <- (CReal_mult_comm r1), <- (CReal_mult_comm r1). + reflexivity. +Qed. + +Lemma CReal_mult_1_l : forall r: CReal, 1 * r == r. +Proof. + intros [rn limr]. split. + - 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. + 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 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 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). + 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 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_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. + discriminate. apply Z.le_refl. +Qed. + +Lemma CReal_isRingExt : ring_eq_ext CReal_plus CReal_mult CReal_opp CRealEq. +Proof. + split. + - intros x y H z t H0. apply CReal_plus_morph; assumption. + - intros x y H z t H0. apply (CRealEq_trans _ (CReal_mult x t)). + apply CReal_mult_proper_l. apply H0. + apply (CRealEq_trans _ (CReal_mult t x)). apply CReal_mult_comm. + apply (CRealEq_trans _ (CReal_mult t y)). + apply CReal_mult_proper_l. apply H. apply CReal_mult_comm. + - intros x y H. apply (CReal_plus_eq_reg_l x). + apply (CRealEq_trans _ (inject_Q 0)). apply CReal_plus_opp_r. + apply (CRealEq_trans _ (CReal_plus y (CReal_opp y))). + apply CRealEq_sym. apply CReal_plus_opp_r. + apply CReal_plus_proper_r. apply CRealEq_sym. apply H. +Qed. + +Lemma CReal_isRing : ring_theory (inject_Q 0) (inject_Q 1) + CReal_plus CReal_mult + CReal_minus CReal_opp + CRealEq. +Proof. + intros. split. + - apply CReal_plus_0_l. + - apply CReal_plus_comm. + - intros x y z. symmetry. apply CReal_plus_assoc. + - apply CReal_mult_1_l. + - apply CReal_mult_comm. + - intros x y z. symmetry. apply CReal_mult_assoc. + - intros x y z. rewrite <- (CReal_mult_comm z). + rewrite CReal_mult_plus_distr_l. + apply (CRealEq_trans _ (CReal_plus (CReal_mult x z) (CReal_mult z y))). + apply CReal_plus_proper_r. apply CReal_mult_comm. + apply CReal_plus_proper_l. apply CReal_mult_comm. + - intros x y. apply CRealEq_refl. + - apply CReal_plus_opp_r. +Qed. + +Add Parametric Morphism : CReal_mult + with signature CRealEq ==> CRealEq ==> CRealEq + as CReal_mult_morph. +Proof. + apply CReal_isRingExt. +Qed. + +Instance CReal_mult_morph_T + : CMorphisms.Proper + (CMorphisms.respectful CRealEq (CMorphisms.respectful CRealEq CRealEq)) CReal_mult. +Proof. + apply CReal_isRingExt. +Qed. + +Add Parametric Morphism : CReal_opp + with signature CRealEq ==> CRealEq + as CReal_opp_morph. +Proof. + apply (Ropp_ext CReal_isRingExt). +Qed. + +Instance CReal_opp_morph_T + : CMorphisms.Proper + (CMorphisms.respectful CRealEq CRealEq) CReal_opp. +Proof. + apply CReal_isRingExt. +Qed. + +Add Parametric Morphism : CReal_minus + with signature CRealEq ==> CRealEq ==> CRealEq + as CReal_minus_morph. +Proof. + intros. unfold CReal_minus. rewrite H,H0. reflexivity. +Qed. + +Instance CReal_minus_morph_T + : CMorphisms.Proper + (CMorphisms.respectful CRealEq (CMorphisms.respectful CRealEq CRealEq)) CReal_minus. +Proof. + intros x y exy z t ezt. unfold CReal_minus. rewrite exy,ezt. reflexivity. +Qed. + +Add Ring CRealRing : CReal_isRing. + +(**********) +Lemma CReal_mult_0_l : forall r, 0 * r == 0. +Proof. + intro; ring. +Qed. + +Lemma CReal_mult_0_r : forall r, r * 0 == 0. +Proof. + intro; ring. +Qed. + +(**********) +Lemma CReal_mult_1_r : forall r, r * 1 == r. +Proof. + intro; ring. +Qed. + +Lemma CReal_opp_mult_distr_l + : forall r1 r2 : CReal, - (r1 * r2) == (- r1) * r2. +Proof. + intros. ring. +Qed. + +Lemma CReal_opp_mult_distr_r + : forall r1 r2 : CReal, - (r1 * r2) == r1 * (- r2). +Proof. + intros. ring. +Qed. + +Lemma CReal_mult_lt_compat_l : forall x y z : CReal, + 0 < x -> y < z -> x*y < x*z. +Proof. + intros. apply (CReal_plus_lt_reg_l + (CReal_opp (CReal_mult x y))). + rewrite CReal_plus_comm. pose proof CReal_plus_opp_r. + unfold CReal_minus in H1. rewrite H1. + rewrite CReal_mult_comm, CReal_opp_mult_distr_l, CReal_mult_comm. + rewrite <- CReal_mult_plus_distr_l. + apply CReal_mult_lt_0_compat. exact H. + apply (CReal_plus_lt_reg_l y). + rewrite CReal_plus_comm, CReal_plus_0_l. + rewrite <- CReal_plus_assoc, H1, CReal_plus_0_l. exact H0. +Qed. + +Lemma CReal_mult_lt_compat_r : forall x y z : CReal, + 0 < x -> y < z -> y*x < z*x. +Proof. + intros. rewrite <- (CReal_mult_comm x), <- (CReal_mult_comm x). + apply (CReal_mult_lt_compat_l x); assumption. +Qed. + +Lemma CReal_mult_eq_reg_l : forall (r r1 r2 : CReal), + r # 0 + -> CRealEq (CReal_mult r r1) (CReal_mult r r2) + -> CRealEq r1 r2. +Proof. + intros. destruct H; split. + - intro abs. apply (CReal_mult_lt_compat_l (-r)) in abs. + rewrite <- CReal_opp_mult_distr_l, <- CReal_opp_mult_distr_l, H0 in abs. + exact (CRealLt_irrefl _ abs). apply (CReal_plus_lt_reg_l r). + rewrite CReal_plus_opp_r, CReal_plus_comm, CReal_plus_0_l. exact c. + - intro abs. apply (CReal_mult_lt_compat_l (-r)) in abs. + rewrite <- CReal_opp_mult_distr_l, <- CReal_opp_mult_distr_l, H0 in abs. + exact (CRealLt_irrefl _ abs). apply (CReal_plus_lt_reg_l r). + rewrite CReal_plus_opp_r, CReal_plus_comm, CReal_plus_0_l. exact c. + - intro abs. apply (CReal_mult_lt_compat_l r) in abs. rewrite H0 in abs. + exact (CRealLt_irrefl _ abs). exact c. + - intro abs. apply (CReal_mult_lt_compat_l r) in abs. rewrite H0 in abs. + exact (CRealLt_irrefl _ abs). exact c. +Qed. + +Lemma CReal_abs_appart_zero : forall (x : CReal) (n : positive), + Qlt (2#n) (Qabs (proj1_sig x (Pos.to_nat n))) + -> 0 # x. +Proof. + intros. destruct x as [xn xcau]. simpl in H. + destruct (Qlt_le_dec 0 (xn (Pos.to_nat 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. + unfold Qminus. rewrite Qplus_0_l. exact H. exact q. +Qed. + + +(*********************************************************) +(** * Field *) +(*********************************************************) + +Lemma CRealArchimedean + : forall x:CReal, { n:Z & x < inject_Q (n#1) < x+2 }. +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. + exists (n+1)%Z. split. + - assert (Qlt 0 ((n + 1 # 1) - (xn 4%nat + (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]. + exists (Pos.max 4 k). simpl. + apply (Qlt_trans _ ((n + 1 # 1) - (xn 4%nat + (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. + 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))). + ring_simplify. + apply (Qle_lt_trans _ (Qabs (xn (Pos.to_nat (Pos.max 4 k)) - xn 4%nat))). + apply Qle_Qabs. apply limx. + rewrite Pos2Nat.inj_max. apply Nat.le_max_l. apply 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). + unfold Pos.to_nat; simpl. + rewrite <- (Qplus_lt_r _ _ (-xn 4%nat)). ring_simplify. + reflexivity. +Defined. + +Definition Rup_pos (x : CReal) + : { n : positive & x < inject_Q (Z.pos n # 1) }. +Proof. + intros. destruct (CRealArchimedean x) as [p [maj _]]. + destruct p. + - exists 1%positive. apply (CReal_lt_trans _ 0 _ maj). apply CRealLt_0_1. + - exists p. exact maj. + - exists 1%positive. apply (CReal_lt_trans _ (inject_Q (Z.neg p # 1)) _ maj). + apply (CReal_lt_trans _ 0). apply inject_Q_lt. reflexivity. + apply CRealLt_0_1. +Qed. + +Lemma CRealLtDisjunctEpsilon : forall a b c d : CReal, + (CRealLtProp a b \/ CRealLtProp c d) -> CRealLt a b + CRealLt c d. +Proof. + intros. + 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))). + { 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. + destruct H as [n maj]. exists (Pos.to_nat n). split. + intro abs. destruct (Pos2Nat.is_succ n). rewrite H in abs. + inversion abs. right. rewrite Pos2Nat.id. apply maj. } + 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. + 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. + - 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))). + 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))). + 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. + apply (Qlt_not_le (2 # Pos.of_nat (S n)) + (proj1_sig d (S n) - proj1_sig c (S n))); assumption. +Qed. + +Lemma CRealShiftReal : forall (x : CReal) (k : nat), + QCauchySeq (fun n => proj1_sig x (plus n k)) Pos.to_nat. +Proof. + intros x k n p q H H0. + 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. +Qed. + +Lemma CRealShiftEqual : forall (x : CReal) (k : nat), + CRealEq x (exist _ (fun n => proj1_sig x (plus 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)). + 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_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. + - intros [n maj]. destruct x as [xn cau]; simpl in maj. + specialize (cau n (Pos.to_nat n) (Pos.to_nat n + k)%nat). + 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_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 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) }. +Proof. + intro xNeg. + pose proof (CRealLt_aboveSig x (inject_Q 0)). + pose proof (CRealShiftReal x). + 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 _]. + 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)))). + 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. +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) }. +Proof. + intro xPos. + pose proof (CRealLt_aboveSig (inject_Q 0) x). + pose proof (CRealShiftReal x). + 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 _]. + 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)))). + 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. +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. +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) + / (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. + { 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 Qmult_lt_l. reflexivity. rewrite Qabs_neg. + specialize (maj (Pos.to_nat k * (Pos.to_nat k * 1) * p)%nat). + 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 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). + 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. + rewrite Qabs_neg. + specialize (maj (Pos.to_nat k * (Pos.to_nat k * 1) * q)%nat). + 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. } + unfold Qdiv. rewrite Qabs_Qmult. rewrite Qabs_Qinv. + rewrite Qmult_comm. rewrite <- (Qmult_comm (/ (1 # k ^ 2))). + apply Qmult_le_compat_r. apply Qlt_le_weak. + rewrite <- Qmult_1_l. apply Qlt_shift_div_r. + apply (Qlt_trans 0 (1 # k ^ 2)). reflexivity. apply H. + rewrite Qmult_comm. apply Qlt_shift_div_l. + 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). + 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 factorDenom. apply Qle_refl. + + field. split. intro abs. + specialize (maj (Pos.to_nat k ^ 2 * p)%nat). + rewrite abs in maj. inversion maj. + intro abs. + specialize (maj (Pos.to_nat k ^ 2 * q)%nat). + 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. +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) + / (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. + { 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 Qmult_lt_l. reflexivity. rewrite Qabs_pos. + specialize (maj (Pos.to_nat k * (Pos.to_nat k * 1) * p)%nat). + 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). + 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). + apply maj. apply (Qle_trans _ (1 # k)). discriminate. + apply Zlt_le_weak. apply maj. } + unfold Qdiv. rewrite Qabs_Qmult. rewrite Qabs_Qinv. + rewrite Qmult_comm. rewrite <- (Qmult_comm (/ (1 # k ^ 2))). + apply Qmult_le_compat_r. apply Qlt_le_weak. + rewrite <- Qmult_1_l. apply Qlt_shift_div_r. + apply (Qlt_trans 0 (1 # k ^ 2)). reflexivity. apply H. + rewrite Qmult_comm. apply Qlt_shift_div_l. + 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). + 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 factorDenom. apply Qle_refl. + + field. split. intro abs. + specialize (maj (Pos.to_nat k ^ 2 * p)%nat). + rewrite abs in maj. inversion maj. + intro abs. + specialize (maj (Pos.to_nat k ^ 2 * q)%nat). + rewrite abs in maj. inversion maj. +Qed. + +Definition CReal_inv (x : CReal) (xnz : x # 0) : CReal. +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))). + 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))). + apply (CReal_inv_pos yn). apply cau. apply maj. +Defined. + +Notation "/ x" := (CReal_inv x) (at level 35, right associativity) : CReal_scope. + +Lemma CReal_inv_0_lt_compat + : forall (r : CReal) (rnz : r # 0), + 0 < r -> 0 < ((/ r) rnz). +Proof. + intros. unfold CReal_inv. simpl. + destruct rnz. + - exfalso. apply CRealLt_asym in H. contradiction. + - 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]. + 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))). + 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))). + apply Qle_Qabs. apply (Qlt_le_trans _ 1). apply cau. + apply Pos2Nat.is_pos. apply 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. + apply Qlt_minus_iff in majA. apply majA. + 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. +Qed. + +Lemma CReal_linear_shift_eq : forall (x : CReal) (k : nat) (kPos : le 1 k), + 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)). +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). + 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. +Qed. + +Lemma CReal_inv_l : forall (r:CReal) (rnz : r # 0), + ((/ r) rnz) * r == 1. +Proof. + intros. unfold CReal_inv; simpl. + destruct rnz. + - (* r < 0 *) destruct (CRealNegShift r c) as [[k rneg] [req maj]]. + simpl in req. apply CRealEq_diff. apply CRealEq_modindep. + apply (QSeqEquivEx_trans _ + (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) + (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 _ + (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)) + (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. + 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 + (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. + 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. + - (* 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)) + (CReal_inv_pos 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 _ + (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)) + (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. + 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 + (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. + 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. +Qed. + +Lemma CReal_inv_r : forall (r:CReal) (rnz : r # 0), + r * ((/ r) rnz) == 1. +Proof. + intros. rewrite CReal_mult_comm, CReal_inv_l. + reflexivity. +Qed. + +Lemma CReal_inv_1 : forall nz : 1 # 0, (/ 1) nz == 1. +Proof. + intros. rewrite <- (CReal_mult_1_l ((/1) nz)). rewrite CReal_inv_r. + reflexivity. +Qed. + +Lemma CReal_inv_mult_distr : + forall r1 r2 (r1nz : r1 # 0) (r2nz : r2 # 0) (rmnz : (r1*r2) # 0), + (/ (r1 * r2)) rmnz == (/ r1) r1nz * (/ r2) r2nz. +Proof. + intros. apply (CReal_mult_eq_reg_l r1). exact r1nz. + rewrite <- CReal_mult_assoc. rewrite CReal_inv_r. rewrite CReal_mult_1_l. + apply (CReal_mult_eq_reg_l r2). exact r2nz. + rewrite CReal_inv_r. rewrite <- CReal_mult_assoc. + rewrite (CReal_mult_comm r2 r1). rewrite CReal_inv_r. + reflexivity. +Qed. + +Lemma Rinv_eq_compat : forall x y (rxnz : x # 0) (rynz : y # 0), + x == y + -> (/ x) rxnz == (/ y) rynz. +Proof. + intros. apply (CReal_mult_eq_reg_l x). exact rxnz. + rewrite CReal_inv_r, H, CReal_inv_r. reflexivity. +Qed. + +Lemma CReal_mult_lt_reg_l : forall r r1 r2, 0 < r -> r * r1 < r * r2 -> r1 < r2. +Proof. + intros z x y H H0. + apply (CReal_mult_lt_compat_l ((/z) (inr H))) in H0. + repeat rewrite <- CReal_mult_assoc in H0. rewrite CReal_inv_l in H0. + repeat rewrite CReal_mult_1_l in H0. apply H0. + apply CReal_inv_0_lt_compat. exact H. +Qed. + +Lemma CReal_mult_lt_reg_r : forall r r1 r2, 0 < r -> r1 * r < r2 * r -> r1 < r2. +Proof. + intros. + apply CReal_mult_lt_reg_l with r. + exact H. + now rewrite 2!(CReal_mult_comm r). +Qed. + +Lemma CReal_mult_eq_reg_r : forall r r1 r2, r1 * r == r2 * r -> r # 0 -> r1 == r2. +Proof. + intros. apply (CReal_mult_eq_reg_l r). exact H0. + now rewrite 2!(CReal_mult_comm r). +Qed. + +Lemma CReal_mult_eq_compat_l : forall r r1 r2, r1 == r2 -> r * r1 == r * r2. +Proof. + intros. rewrite H. reflexivity. +Qed. + +Lemma CReal_mult_eq_compat_r : forall r r1 r2, r1 == r2 -> r1 * r == r2 * r. +Proof. + intros. rewrite H. reflexivity. +Qed. + +(* In particular x * y == 1 implies that 0 # x, 0 # y and + that x and y are inverses of each other. *) +Lemma CReal_mult_pos_appart_zero : forall x y : CReal, 0 < x * y -> 0 # x. +Proof. + intros. destruct (linear_order_T 0 x 1 (CRealLt_0_1)). + left. exact c. destruct (linear_order_T (CReal_opp 1) x 0). + rewrite <- CReal_opp_0. apply CReal_opp_gt_lt_contravar, CRealLt_0_1. + 2: right; exact c0. + pose proof (CRealLt_above _ _ H). destruct H0 as [k kmaj]. + simpl in kmaj. + 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. + 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). + - apply (Qlt_trans _ (2#k)). + + unfold Qlt. rewrite <- Z.mul_lt_mono_pos_l. 2: reflexivity. + unfold Qden. apply Pos2Z.pos_lt_pos. + apply (Pos.le_lt_trans _ (1 * Pos.max k (Pos.max i j))). + rewrite Pos.mul_1_l. apply Pos.le_max_l. + apply Pos2Nat.inj_lt. do 2 rewrite Pos2Nat.inj_mul. + rewrite <- Nat.mul_lt_mono_pos_r. 2: apply Pos2Nat.is_pos. + 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)))))). + 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)). + reflexivity. apply jmaj. + 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_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. + 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. + - 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))). + rewrite <- CReal_opp_0. apply CReal_opp_gt_lt_contravar. exact c. + rewrite CReal_mult_0_l, <- CReal_opp_0, <- CReal_opp_mult_distr_r. + apply CReal_opp_gt_lt_contravar. exact H. +Qed. + +Fixpoint pow (r:CReal) (n:nat) : CReal := + match n with + | O => 1 + | S n => r * (pow r n) + end. + + +Lemma CReal_mult_le_compat_l_half : forall r r1 r2, + 0 < r -> r1 <= r2 -> r * r1 <= r * r2. +Proof. + intros. intro abs. apply (CReal_mult_lt_reg_l) in abs. + contradiction. apply H. +Qed. + +Lemma 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)). +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. + do 2 rewrite Pos.mul_1_r. rewrite Z.pos_sub_diag. discriminate. +Qed. + +Definition CRealQ_dense (a b : CReal) + : a < b -> { q : Q & a < inject_Q q < b }. +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. + 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))). + 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. + rewrite Qplus_comm. exact pmaj. + - 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)))). + 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))). + 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. + setoid_replace (2*(1#p))%Q with (2#p)%Q. 2: reflexivity. exact pmaj. +Qed. + +Lemma inject_Q_mult : forall q r : Q, + inject_Q (q * r) == inject_Q q * inject_Q r. +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/ConstructiveRIneq.v b/theories/Reals/ConstructiveRIneq.v index b53436be55..e0f08d2fbe 100644 --- a/theories/Reals/ConstructiveRIneq.v +++ b/theories/Reals/ConstructiveRIneq.v @@ -22,9 +22,8 @@ constructive reals, do not use ConstructiveCauchyReals directly. *) -Require Import ConstructiveCauchyReals. +Require Import ConstructiveCauchyRealsMult. Require Import ConstructiveRcomplete. -Require Import ConstructiveRealsLUB. Require Export ConstructiveReals. Require Import Zpower. Require Export ZArithRing. @@ -37,11 +36,11 @@ Declare Scope R_scope_constr. Local Open Scope Z_scope. Local Open Scope R_scope_constr. -Definition CR : ConstructiveReals. +Definition CRealImplem : ConstructiveReals. Proof. assert (isLinearOrder CReal CRealLt) as lin. { repeat split. exact CRealLt_asym. - exact CRealLt_trans. + exact CReal_lt_trans. intros. destruct (CRealLt_dec x z y H). left. exact c. right. exact c. } apply (Build_ConstructiveReals @@ -53,30 +52,25 @@ Proof. CReal_plus_lt_compat_l CReal_plus_lt_reg_l CReal_mult_lt_0_compat CReal_inv CReal_inv_l CReal_inv_0_lt_compat - CRealArchimedean). + inject_Q inject_Q_plus inject_Q_mult + inject_Q_one inject_Q_lt lt_inject_Q + CRealQ_dense Rup_pos). - intros. destruct (Rcauchy_complete xn) as [l cv]. - intro n. apply (H (IQR (1#n))). apply IQR_pos. reflexivity. - exists l. intros eps epsPos. - destruct (Rup_nat ((/eps) (inr epsPos))) as [n nmaj]. - specialize (cv (Pos.of_nat (S n))) as [p pmaj]. - exists p. intros. specialize (pmaj i H0). unfold absSmall in pmaj. - apply (CReal_mult_lt_compat_l eps) in nmaj. - rewrite CReal_inv_r, CReal_mult_comm in nmaj. - 2: apply epsPos. split. - + apply (CRealLt_trans _ (-IQR (1 # Pos.of_nat (S n)))). - 2: apply pmaj. clear pmaj. - apply CReal_opp_gt_lt_contravar. unfold CRealGt, IQR. - rewrite CReal_mult_1_l. apply (CReal_mult_lt_reg_l (IPR (Pos.of_nat (S n)))). - apply IPR_pos. rewrite CReal_inv_r, <- INR_IPR, Nat2Pos.id. - 2: discriminate. apply (CRealLt_trans _ (INR n * eps) _ nmaj). - apply CReal_mult_lt_compat_r. exact epsPos. apply lt_INR, le_refl. - + apply (CRealLt_trans _ (IQR (1 # Pos.of_nat (S n)))). - apply pmaj. unfold IQR. rewrite CReal_mult_1_l. - apply (CReal_mult_lt_reg_l (IPR (Pos.of_nat (S n)))). - apply IPR_pos. rewrite CReal_inv_r, <- INR_IPR, Nat2Pos.id. - 2: discriminate. apply (CRealLt_trans _ (INR n * eps) _ nmaj). - apply CReal_mult_lt_compat_r. exact epsPos. apply lt_INR, le_refl. - - exact sig_lub. + intro n. destruct (H n). exists x. intros. + specialize (a i j H0 H1) as [a b]. split. 2: exact b. + rewrite <- opp_inject_Q. + setoid_replace (-(1#n))%Q with (-1#n). exact a. reflexivity. + exists l. intros p. destruct (cv p). + exists x. intros. specialize (a i H0). split. 2: apply a. + unfold orderLe. + intro abs. setoid_replace (-1#p) with (-(1#p))%Q in abs. + rewrite opp_inject_Q in abs. destruct a. contradiction. + reflexivity. +Defined. + +Definition CR : ConstructiveReals. +Proof. + exact CRealImplem. Qed. (* Keep it opaque to possibly change the implementation later *) Definition R := CRcarrier CR. @@ -1673,6 +1667,19 @@ Proof. intro; destruct n. rewrite Rplus_0_l. reflexivity. reflexivity. Qed. +(**********) +Lemma IZN : forall n:Z, (0 <= n)%Z -> { m : nat | n = Z.of_nat m }. +Proof. + intros. exists (Z.to_nat n). rewrite Z2Nat.id. reflexivity. assumption. +Qed. + +Lemma le_succ_r_T : forall n m : nat, (n <= S m)%nat -> {(n <= m)%nat} + {n = S m}. +Proof. + intros. destruct (le_lt_dec n m). left. exact l. + right. apply Nat.le_succ_r in H. destruct H. + exfalso. apply (le_not_lt n m); assumption. exact H. +Qed. + Lemma lt_INR : forall n m:nat, (n < m)%nat -> INR n < INR m. Proof. induction m. @@ -2174,35 +2181,29 @@ Proof. contradiction. apply H. Qed. -Lemma INR_gen_phiZ : forall (n : nat), - gen_phiZ 0 1 Rplus Rmult Ropp (Z.of_nat n) == INR n. +Lemma INR_CR_of_Q : forall (n : nat), + CR_of_Q CR (Z.of_nat n # 1) == INR n. Proof. induction n. - - apply Req_refl. - - replace (Z.of_nat (S n)) with (1 + Z.of_nat n)%Z. - rewrite (gen_phiZ_add Req_rel (CRisRingExt CR) RisRing). - rewrite IHn. clear IHn. simpl. rewrite (Rplus_comm 1). - destruct n. rewrite Rplus_0_l. reflexivity. reflexivity. + - apply CR_of_Q_zero. + - transitivity (CR_of_Q CR (1 + (Z.of_nat n # 1))). replace (S n) with (1 + n)%nat. 2: reflexivity. - rewrite (Nat2Z.inj_add 1 n). reflexivity. + rewrite (Nat2Z.inj_add 1 n). + apply CR_of_Q_proper. + rewrite <- (Qinv_plus_distr (Z.of_nat 1) (Z.of_nat n) 1). reflexivity. + rewrite CR_of_Q_plus. rewrite IHn. clear IHn. + setoid_replace (INR (S n)) with (1 + INR n). + rewrite CR_of_Q_one. reflexivity. + simpl. destruct n. rewrite Rplus_0_r. reflexivity. + rewrite Rplus_comm. reflexivity. Qed. Definition Rup_nat (x : R) : { n : nat & x < INR n }. Proof. - intros. destruct (CRarchimedean CR x) as [p maj]. - destruct p. - - exists O. apply maj. - - exists (Pos.to_nat p). - rewrite <- positive_nat_Z, (INR_gen_phiZ (Pos.to_nat p)) in maj. exact maj. - - exists O. apply (Rlt_trans _ _ _ maj). simpl. - rewrite <- Ropp_0. apply Ropp_gt_lt_contravar. - fold (gen_phiZ 0 1 Rplus Rmult Ropp (Z.pos p)). - replace (gen_phiPOS 1 (CRplus CR) (CRmult CR) p) - with (gen_phiZ 0 1 Rplus Rmult Ropp (Z.pos p)). - 2: reflexivity. - rewrite <- positive_nat_Z, (INR_gen_phiZ (Pos.to_nat p)). - apply (lt_INR 0). apply Pos2Nat.is_pos. + intros. destruct (CR_archimedean CR x) as [p maj]. + exists (Pos.to_nat p). + rewrite <- INR_CR_of_Q, positive_nat_Z. exact maj. Qed. Fixpoint Rarchimedean_ind (x:R) (n : Z) (p:nat) { struct p } diff --git a/theories/Reals/ConstructiveRcomplete.v b/theories/Reals/ConstructiveRcomplete.v index ce45bcd567..0a515672f2 100644 --- a/theories/Reals/ConstructiveRcomplete.v +++ b/theories/Reals/ConstructiveRcomplete.v @@ -11,227 +11,145 @@ Require Import QArith_base. Require Import Qabs. -Require Import ConstructiveCauchyReals. +Require Import ConstructiveCauchyRealsMult. Require Import Logic.ConstructiveEpsilon. Local Open Scope CReal_scope. +Definition absLe (a b : CReal) : Prop + := -b <= a <= b. + Lemma CReal_absSmall : forall (x y : CReal) (n : positive), (Qlt (2 # n) (proj1_sig x (Pos.to_nat n) - Qabs (proj1_sig y (Pos.to_nat n)))) - -> (CRealLt (CReal_opp x) y * CRealLt y x). + -> absLe y x. Proof. intros x y n maj. split. - - exists n. destruct x as [xn caux], y as [yn cauy]; simpl. + - 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. - - exists n. destruct x as [xn caux], y as [yn cauy]; simpl. + - 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. -Definition absSmall (a b : CReal) : Set - := -b < a < b. - +(* We use absLe in sort Prop rather than Set, + to extract smaller programs. *) Definition Un_cv_mod (un : nat -> CReal) (l : CReal) : Set - := forall n : positive, - { p : nat & forall i:nat, le p i -> absSmall (un i - l) (IQR (1#n)) }. + := forall p : positive, + { n : nat | forall i:nat, le n i -> absLe (un i - l) (inject_Q (1#p)) }. Lemma Un_cv_mod_eq : forall (v u : nat -> CReal) (s : CReal), (forall n:nat, u n == v n) - -> Un_cv_mod u s -> Un_cv_mod v s. + -> Un_cv_mod u s + -> Un_cv_mod v s. Proof. intros v u s seq H1 p. specialize (H1 p) as [N H0]. - exists N. intros. unfold absSmall. split. + exists N. intros. split. rewrite <- seq. apply H0. apply H. rewrite <- seq. apply H0. apply H. Qed. Definition Un_cauchy_mod (un : nat -> CReal) : Set - := forall n : positive, - { p : nat & forall i j:nat, le p i - -> le p j - -> -IQR (1#n) < un i - un j < IQR (1#n) }. + := forall p : positive, + { n : nat | forall i j:nat, le n i -> le n j + -> absLe (un i - un j) (inject_Q (1#p)) }. (* Sharpen the archimedean property : constructive versions of - the usual floor and ceiling functions. - - n is a temporary parameter used for the recursion, - look at Ffloor below. *) -Fixpoint Rfloor_pos (a : CReal) (n : nat) { struct n } - : 0 < a - -> a < INR n - -> { p : nat & INR p < a < INR p + 2 }. -Proof. - (* Decreasing loop on n, until it is the first integer above a. *) - intros H H0. destruct n. - - exfalso. apply (CRealLt_asym 0 a); assumption. - - destruct n as [|p] eqn:des. - + (* n = 1 *) exists O. split. - apply H. rewrite CReal_plus_0_l. apply (CRealLt_trans a (1+0)). - rewrite CReal_plus_comm, CReal_plus_0_l. apply H0. - apply CReal_plus_le_lt_compat. - apply CRealLe_refl. apply CRealLt_0_1. - + (* n > 1 *) - destruct (linear_order_T (INR p) a (INR (S p))). - * rewrite <- CReal_plus_0_l, S_INR, CReal_plus_comm. apply CReal_plus_lt_compat_l. - apply CRealLt_0_1. - * exists p. split. exact c. - rewrite S_INR, S_INR, CReal_plus_assoc in H0. exact H0. - * apply (Rfloor_pos a n H). rewrite des. apply c. -Qed. - + the usual floor and ceiling functions. *) Definition Rfloor (a : CReal) - : { p : Z & IZR p < a < IZR p + 2 }. + : { p : Z & inject_Q (p#1) < a < inject_Q (p#1) + 2 }. Proof. - assert (forall x:CReal, 0 < x -> { n : nat & x < INR n }). - { intros. pose proof (Rarchimedean x) as [n [maj _]]. - destruct n. - + exfalso. apply (CRealLt_asym 0 x); assumption. - + exists (Pos.to_nat p). rewrite INR_IPR. apply maj. - + exfalso. apply (CRealLt_asym 0 x). apply H. - apply (CRealLt_trans x (IZR (Z.neg p))). apply maj. - apply (CReal_plus_lt_reg_l (-IZR (Z.neg p))). - rewrite CReal_plus_comm, CReal_plus_opp_r. rewrite <- opp_IZR. - rewrite CReal_plus_comm, CReal_plus_0_l. - apply (IZR_lt 0). reflexivity. } - destruct (linear_order_T 0 a 1 CRealLt_0_1). - - destruct (H a c). destruct (Rfloor_pos a x c c0). - exists (Z.of_nat x0). split; rewrite <- INR_IZR_INZ; apply p. - - apply (CReal_plus_lt_compat_l (-a)) in c. - rewrite CReal_plus_comm, CReal_plus_opp_r, CReal_plus_comm in c. - destruct (H (1-a) c). - destruct (Rfloor_pos (1-a) x c c0). - exists (-(Z.of_nat x0 + 1))%Z. split; rewrite opp_IZR, plus_IZR. - + rewrite <- (CReal_opp_involutive a). apply CReal_opp_gt_lt_contravar. - destruct p as [_ a0]. apply (CReal_plus_lt_reg_r 1). - rewrite CReal_plus_comm, CReal_plus_assoc. rewrite <- INR_IZR_INZ. apply a0. - + destruct p as [a0 _]. apply (CReal_plus_lt_compat_l a) in a0. - unfold CReal_minus in a0. - rewrite <- (CReal_plus_comm (1+-a)), CReal_plus_assoc, CReal_plus_opp_l, CReal_plus_0_r in a0. - rewrite <- INR_IZR_INZ. - apply (CReal_plus_lt_reg_r (INR x0)). unfold IZR, IPR, IPR_2. - ring_simplify. exact a0. -Qed. + destruct (CRealArchimedean a) as [n [H H0]]. + exists (n-2)%Z. split. + - setoid_replace (n - 2 # 1)%Q with ((n#1) + - 2)%Q. + rewrite inject_Q_plus, (opp_inject_Q 2). + apply (CReal_plus_lt_reg_r 2). ring_simplify. + rewrite CReal_plus_comm. exact H0. + rewrite Qinv_plus_distr. reflexivity. + - setoid_replace (n - 2 # 1)%Q with ((n#1) + - 2)%Q. + rewrite inject_Q_plus, (opp_inject_Q 2). + ring_simplify. exact H. + rewrite Qinv_plus_distr. reflexivity. +Defined. -Definition Rup_nat (x : CReal) - : { n : nat & x < INR n }. -Proof. - intros. destruct (Rarchimedean x) as [p [maj _]]. - destruct p. - - exists O. apply maj. - - exists (Pos.to_nat p). rewrite INR_IPR. apply maj. - - exists O. apply (CRealLt_trans _ (IZR (Z.neg p)) _ maj). - apply (IZR_lt _ 0). reflexivity. -Qed. (* A point in an archimedean field is the limit of a sequence of rational numbers (n maps to the q between a and a+1/n). This will yield a maximum archimedean field, which is the field of real numbers. *) -Definition FQ_dense_pos (a b : CReal) - : 0 < b - -> a < b -> { q : Q & a < IQR q < b }. -Proof. - intros H H0. - assert (0 < b - a) as epsPos. - { apply (CReal_plus_lt_compat_l (-a)) in H0. - rewrite CReal_plus_opp_l, CReal_plus_comm in H0. - apply H0. } - pose proof (Rup_nat ((/(b-a)) (inr epsPos))) - as [n maj]. - destruct n as [|k]. - - exfalso. - apply (CReal_mult_lt_compat_l (b-a)) in maj. 2: apply epsPos. - rewrite CReal_mult_0_r in maj. rewrite CReal_inv_r in maj. - apply (CRealLt_asym 0 1). apply CRealLt_0_1. apply maj. - - (* 0 < n *) - pose (Pos.of_nat (S k)) as n. - destruct (Rfloor (IZR (2 * Z.pos n) * b)) as [p maj2]. - exists (p # (2*n))%Q. split. - + apply (CRealLt_trans a (b - IQR (1 # n))). - apply (CReal_plus_lt_reg_r (IQR (1#n))). - unfold CReal_minus. rewrite CReal_plus_assoc. rewrite CReal_plus_opp_l. - rewrite CReal_plus_0_r. apply (CReal_plus_lt_reg_l (-a)). - rewrite <- CReal_plus_assoc, CReal_plus_opp_l, CReal_plus_0_l. - rewrite CReal_plus_comm. unfold IQR. - rewrite CReal_mult_1_l. apply (CReal_mult_lt_reg_l (IPR n)). - apply IPR_pos. rewrite CReal_inv_r. - apply (CReal_mult_lt_compat_l (b-a)) in maj. - rewrite CReal_inv_r, CReal_mult_comm in maj. - rewrite <- INR_IPR. unfold n. rewrite Nat2Pos.id. - apply maj. discriminate. exact epsPos. - apply (CReal_plus_lt_reg_r (IQR (1 # n))). - unfold CReal_minus. rewrite CReal_plus_assoc, CReal_plus_opp_l. - rewrite CReal_plus_0_r. rewrite <- plus_IQR. - destruct maj2 as [_ maj2]. - setoid_replace ((p # 2 * n) + (1 # n))%Q - with ((p + 2 # 2 * n))%Q. unfold IQR. - apply (CReal_mult_lt_reg_r (IZR (Z.pos (2 * n)))). - apply (IZR_lt 0). reflexivity. rewrite CReal_mult_assoc. - rewrite CReal_inv_l. rewrite CReal_mult_1_r. rewrite CReal_mult_comm. - rewrite plus_IZR. apply maj2. - setoid_replace (1#n)%Q with (2#2*n)%Q. 2: reflexivity. - apply Qinv_plus_distr. - + destruct maj2 as [maj2 _]. unfold IQR. - apply (CReal_mult_lt_reg_r (IZR (Z.pos (2 * n)))). - apply (IZR_lt 0). apply Pos2Z.is_pos. rewrite CReal_mult_assoc, CReal_inv_l. - rewrite CReal_mult_1_r, CReal_mult_comm. apply maj2. -Qed. - Definition FQ_dense (a b : CReal) - : a < b - -> { q : Q & a < IQR q < b }. + : a < b -> { q : Q & a < inject_Q q < b }. Proof. - intros H. destruct (linear_order_T a 0 b). apply H. - - destruct (FQ_dense_pos (-b) (-a)) as [q maj]. - apply (CReal_plus_lt_compat_l (-a)) in c. rewrite CReal_plus_opp_l in c. - rewrite CReal_plus_0_r in c. apply c. - apply (CReal_plus_lt_compat_l (-a)) in H. + intros H. assert (0 < b - a) as epsPos. + { apply (CReal_plus_lt_compat_l (-a)) in H. rewrite CReal_plus_opp_l, CReal_plus_comm in H. - apply (CReal_plus_lt_compat_l (-b)) in H. rewrite <- CReal_plus_assoc in H. - rewrite CReal_plus_opp_l in H. rewrite CReal_plus_0_l in H. - rewrite CReal_plus_0_r in H. apply H. - exists (-q)%Q. split. - + destruct maj as [_ maj]. - apply (CReal_plus_lt_compat_l (-IQR q)) in maj. - rewrite CReal_plus_opp_l, <- opp_IQR, CReal_plus_comm in maj. - apply (CReal_plus_lt_compat_l a) in maj. rewrite <- CReal_plus_assoc in maj. - rewrite CReal_plus_opp_r, CReal_plus_0_l in maj. - rewrite CReal_plus_0_r in maj. apply maj. - + destruct maj as [maj _]. - apply (CReal_plus_lt_compat_l (-IQR q)) in maj. - rewrite CReal_plus_opp_l, <- opp_IQR, CReal_plus_comm in maj. - apply (CReal_plus_lt_compat_l b) in maj. rewrite <- CReal_plus_assoc in maj. - rewrite CReal_plus_opp_r in maj. rewrite CReal_plus_0_l in maj. - rewrite CReal_plus_0_r in maj. apply maj. - - apply FQ_dense_pos. apply c. apply H. + apply H. } + pose proof (Rup_pos ((/(b-a)) (inr epsPos))) + as [n maj]. + destruct (Rfloor (inject_Q (2 * Z.pos n # 1) * b)) as [p maj2]. + exists (p # (2*n))%Q. split. + - apply (CReal_lt_trans a (b - inject_Q (1 # n))). + apply (CReal_plus_lt_reg_r (inject_Q (1#n))). + unfold CReal_minus. rewrite CReal_plus_assoc. rewrite CReal_plus_opp_l. + rewrite CReal_plus_0_r. apply (CReal_plus_lt_reg_l (-a)). + rewrite <- CReal_plus_assoc, CReal_plus_opp_l, CReal_plus_0_l. + rewrite CReal_plus_comm. + apply (CReal_mult_lt_reg_l (inject_Q (Z.pos n # 1))). + apply inject_Q_lt. reflexivity. rewrite <- inject_Q_mult. + setoid_replace ((Z.pos n # 1) * (1 # n))%Q with 1%Q. + apply (CReal_mult_lt_compat_l (b-a)) in maj. + rewrite CReal_inv_r, CReal_mult_comm in maj. exact maj. + exact epsPos. unfold Qeq; simpl. do 2 rewrite Pos.mul_1_r. reflexivity. + apply (CReal_plus_lt_reg_r (inject_Q (1 # n))). + unfold CReal_minus. rewrite CReal_plus_assoc, CReal_plus_opp_l. + rewrite CReal_plus_0_r. rewrite <- inject_Q_plus. + destruct maj2 as [_ maj2]. + setoid_replace ((p # 2 * n) + (1 # n))%Q + with ((p + 2 # 2 * n))%Q. + apply (CReal_mult_lt_reg_r (inject_Q (Z.pos (2 * n) # 1))). + apply inject_Q_lt. reflexivity. rewrite <- inject_Q_mult. + setoid_replace ((p + 2 # 2 * n) * (Z.pos (2 * n) # 1))%Q + with ((p#1) + 2)%Q. + rewrite inject_Q_plus. rewrite Pos2Z.inj_mul. + rewrite CReal_mult_comm. exact maj2. + unfold Qeq; simpl. rewrite Pos.mul_1_r, Z.mul_1_r. ring. + setoid_replace (1#n)%Q with (2#2*n)%Q. 2: reflexivity. + apply Qinv_plus_distr. + - destruct maj2 as [maj2 _]. + apply (CReal_mult_lt_reg_r (inject_Q (Z.pos (2 * n) # 1))). + apply inject_Q_lt. reflexivity. + rewrite <- inject_Q_mult. + setoid_replace ((p # 2 * n) * (Z.pos (2 * n) # 1))%Q + with ((p#1))%Q. + rewrite CReal_mult_comm. exact maj2. + 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 < IQR q < x + IQR (1 # Pos.of_nat n) }. + { q:Q & x < inject_Q q < x + inject_Q (1 # Pos.of_nat n) }. Proof. - intros x n. apply (FQ_dense x (x + IQR (1 # Pos.of_nat n))). + 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 IQR_pos. + apply CReal_plus_lt_compat_l. rewrite CReal_plus_0_l. apply inject_Q_lt. reflexivity. Qed. Definition Un_cauchy_Q (xn : nat -> Q) : Set := forall n : positive, { k : nat | forall p q : nat, le k p -> le k q - -> Qlt (-(1#n)) (xn p - xn q) - /\ Qlt (xn p - xn q) (1#n) }. + -> Qle (-(1#n)) (xn p - xn q) + /\ Qle (xn p - xn q) (1#n) }. Lemma Rdiag_cauchy_sequence : forall (xn : nat -> CReal), Un_cauchy_mod xn - -> Un_cauchy_Q (fun n => let (l,_) := RQ_limit (xn n) n in l). + -> 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. @@ -241,67 +159,69 @@ Proof. apply (le_trans _ (Init.Nat.max k (2 * Pos.to_nat p))). apply Nat.le_max_l. apply H0. split. - - apply lt_IQR. unfold Qminus. - apply (CRealLt_trans _ (xn p0 - (xn q + IQR (1 # 2 * p)))). - + unfold CReal_minus. rewrite CReal_opp_plus_distr. unfold CReal_minus. + - 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_lt_reg_r (IQR (1 # 2 * p))). + apply (CReal_plus_le_reg_r (inject_Q (1 # 2 * p))). rewrite CReal_plus_assoc. rewrite CReal_plus_opp_l. rewrite CReal_plus_0_r. - rewrite <- plus_IQR. + rewrite <- inject_Q_plus. setoid_replace (- (1 # p) + (1 # 2 * p))%Q with (- (1 # 2 * p))%Q. - rewrite opp_IQR. exact c. + rewrite opp_inject_Q. exact H1. rewrite Qplus_comm. setoid_replace (1#p)%Q with (2 # 2 *p)%Q. rewrite Qinv_minus_distr. reflexivity. reflexivity. - + rewrite plus_IQR. apply CReal_plus_le_lt_compat. + + rewrite inject_Q_plus. apply CReal_plus_le_compat. apply CRealLt_asym. destruct (RQ_limit (xn p0) p0); simpl. apply p1. + apply CRealLt_asym. destruct (RQ_limit (xn q) q); unfold proj1_sig. - rewrite opp_IQR. apply CReal_opp_gt_lt_contravar. - apply (CRealLt_Le_trans _ (xn q + IQR (1 # Pos.of_nat q))). - apply p1. apply CReal_plus_le_compat_l. apply IQR_le. + rewrite opp_inject_Q. apply CReal_opp_gt_lt_contravar. + apply (CReal_lt_le_trans _ (xn q + inject_Q (1 # Pos.of_nat q))). + apply p1. apply CReal_plus_le_compat_l. apply inject_Q_le. 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 lt_IQR. unfold Qminus. - apply (CRealLt_trans _ (xn p0 + IQR (1 # 2 * p) - xn q)). - + rewrite plus_IQR. apply CReal_plus_le_lt_compat. + rewrite Nat2Pos.id. apply H3. intro abs. subst q. + inversion H3. pose proof (Pos2Nat.is_pos (p~0)). + rewrite H5 in H4. inversion H4. + - 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 (CRealLt_Le_trans _ (xn p0 + IQR (1 # Pos.of_nat p0))). - apply p1. apply CReal_plus_le_compat_l. apply IQR_le. + apply (CReal_lt_le_trans _ (xn p0 + inject_Q (1 # Pos.of_nat p0))). + apply p1. apply CReal_plus_le_compat_l. apply inject_Q_le. apply 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. - rewrite opp_IQR. apply CReal_opp_gt_lt_contravar. + rewrite Nat2Pos.id. apply H3. intro abs. subst p0. + inversion H3. pose proof (Pos2Nat.is_pos (p~0)). + rewrite H5 in H4. inversion H4. + apply CRealLt_asym. + rewrite opp_inject_Q. apply CReal_opp_gt_lt_contravar. destruct (RQ_limit (xn q) q); simpl. apply p1. + unfold CReal_minus. rewrite (CReal_plus_comm (xn p0)). rewrite CReal_plus_assoc. - apply (CReal_plus_lt_reg_l (- IQR (1 # 2 * p))). + 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_IQR. rewrite <- plus_IQR. + rewrite <- opp_inject_Q. rewrite <- inject_Q_plus. setoid_replace (- (1 # 2 * p) + (1 # p))%Q with (1 # 2 * p)%Q. - exact c0. rewrite Qplus_comm. + exact H2. rewrite Qplus_comm. setoid_replace (1#p)%Q with (2 # 2*p)%Q. rewrite Qinv_minus_distr. reflexivity. reflexivity. Qed. -Lemma doubleLtCovariant : forall a b c d e f : CReal, +Lemma doubleLeCovariant : forall a b c d e f : CReal, a == b -> c == d -> e == f - -> (a < c < e) - -> (b < d < f). + -> (a <= c <= e) + -> (b <= d <= f). Proof. split. rewrite <- H. rewrite <- H0. apply H2. rewrite <- H0. rewrite <- H1. apply H2. @@ -311,15 +231,13 @@ Qed. show that it converges to itself in CReal. *) Lemma CReal_cv_self : forall (qn : nat -> Q) (x : CReal) (cvmod : positive -> nat), QSeqEquiv qn (fun n => proj1_sig x n) cvmod - -> Un_cv_mod (fun n => IQR (qn n)) x. + -> Un_cv_mod (fun n => inject_Q (qn n)) x. Proof. intros qn x cvmod H p. specialize (H (2*p)%positive). exists (cvmod (2*p)%positive). - intros p0 H0. unfold absSmall, CReal_minus. - apply (doubleLtCovariant (-inject_Q (1#p)) _ (inject_Q (qn p0) - x) _ (inject_Q (1#p))). - rewrite FinjectQ_CReal. reflexivity. - rewrite FinjectQ_CReal. reflexivity. - rewrite FinjectQ_CReal. reflexivity. + intros p0 H0. unfold absLe, CReal_minus. + apply (doubleLeCovariant (-inject_Q (1#p)) _ (inject_Q (qn p0) - x) _ (inject_Q (1#p))). + reflexivity. reflexivity. reflexivity. apply (CReal_absSmall _ _ (Pos.max (4 * p)%positive (Pos.of_nat (cvmod (2 * p)%positive)))). 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. @@ -353,7 +271,7 @@ Lemma Un_cv_extens : forall (xn yn : nat -> CReal) (l : CReal), -> Un_cv_mod yn l. Proof. intros. intro p. destruct (H p) as [n cv]. exists n. - intros. unfold absSmall, CReal_minus. + intros. unfold absLe, CReal_minus. split; rewrite <- (H0 i); apply cv; apply H1. Qed. @@ -362,29 +280,28 @@ Qed. The biggest computable such field has all rational limits. *) Lemma R_has_all_rational_limits : forall qn : nat -> Q, Un_cauchy_Q qn - -> { r : CReal & Un_cv_mod (fun n => IQR (qn n)) r }. + -> { r : CReal & Un_cv_mod (fun n:nat => inject_Q (qn n)) r }. Proof. - (* qn is an element of CReal. Show that IQR qn + (* 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 p))). - - intros p n k H0 H1. destruct (H p); simpl in H0,H1. - specialize (a n k H0 H1). apply Qabs_case. - intros _. apply a. intros _. - apply (Qplus_lt_r _ _ (qn n -qn k-(1#p))). ring_simplify. - destruct a. ring_simplify in H2. exact H2. + destruct (standard_modulus qn (fun p => proj1_sig (H (Pos.succ p)))). + - intros p n k H0 H1. destruct (H (Pos.succ p)%positive) as [x a]; simpl in H0,H1. + specialize (a n k H0 H1). + apply (Qle_lt_trans _ (1#Pos.succ p)). + apply Qabs_Qle_condition. exact a. + apply 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 p)) n)) H0). - apply (Un_cv_extens (fun n : nat => IQR (qn n))). + 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 p)) n)) H0) - (fun p : positive => Init.Nat.max (proj1_sig (H p)) (Pos.to_nat p))). - apply H1. intro n. reflexivity. + 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. Qed. Lemma Rcauchy_complete : forall (xn : nat -> CReal), Un_cauchy_mod xn - -> { l : CReal & Un_cv_mod xn l }. + -> { l : CReal & Un_cv_mod xn l }. Proof. intros xn cau. destruct (R_has_all_rational_limits (fun n => let (l,_) := RQ_limit (xn n) n in l) @@ -396,21 +313,21 @@ Proof. apply Nat.le_max_l. apply H. destruct (RQ_limit (xn p0) p0) as [q maj]; unfold proj1_sig in H0,H1. split. - - apply (CRealLt_trans _ (IQR q - IQR (1 # 2 * p) - l)). - + unfold CReal_minus. rewrite (CReal_plus_comm (IQR q)). - apply (CReal_plus_lt_reg_l (IQR (1 # 2 * p))). - ring_simplify. unfold CReal_minus. rewrite <- opp_IQR. rewrite <- plus_IQR. + - apply (CReal_le_trans _ (inject_Q q - inject_Q (1 # 2 * p) - l)). + + unfold CReal_minus. rewrite (CReal_plus_comm (inject_Q q)). + apply (CReal_plus_le_reg_l (inject_Q (1 # 2 * p))). + ring_simplify. unfold CReal_minus. rewrite <- opp_inject_Q. rewrite <- inject_Q_plus. setoid_replace ((1 # 2 * p) + - (1 # p))%Q with (-(1#2*p))%Q. - rewrite opp_IQR. apply H0. + rewrite opp_inject_Q. apply H0. 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_lt_compat_l. - apply (CReal_plus_lt_reg_r (IQR (1 # 2 * p))). + 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 (CRealLt_Le_trans _ (xn p0 + IQR (1 # Pos.of_nat p0))). - apply maj. apply CReal_plus_le_compat_l. - apply IQR_le. + 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))). @@ -420,13 +337,13 @@ Proof. rewrite Nat2Pos.id. apply H2. intro abs. subst p0. inversion H2. pose proof (Pos2Nat.is_pos (p~0)). rewrite H4 in H3. inversion H3. - - apply (CRealLt_trans _ (IQR q - l)). + - apply (CReal_le_trans _ (inject_Q q - l)). + unfold CReal_minus. do 2 rewrite <- (CReal_plus_comm (-l)). - apply CReal_plus_lt_compat_l. apply maj. - + apply (CRealLt_trans _ (IQR (1 # 2 * p))). - apply H1. apply IQR_lt. + apply CReal_plus_le_compat_l. apply CRealLt_asym, maj. + + apply (CReal_le_trans _ (inject_Q (1 # 2 * p))). + apply H1. apply inject_Q_le. rewrite <- Qplus_0_r. setoid_replace (1#p)%Q with ((1#2*p)+(1#2*p))%Q. - apply Qplus_lt_r. reflexivity. + apply Qplus_le_r. discriminate. rewrite Qinv_plus_distr. reflexivity. Qed. diff --git a/theories/Reals/ConstructiveReals.v b/theories/Reals/ConstructiveReals.v index fc3d6afe15..25242f5ea9 100644 --- a/theories/Reals/ConstructiveReals.v +++ b/theories/Reals/ConstructiveReals.v @@ -9,10 +9,10 @@ (************************************************************************) (************************************************************************) -(* An interface for constructive and computable real numbers. - All of its instances are isomorphic, for example it contains - the Cauchy reals implemented in file ConstructivecauchyReals - and the sumbool-based Dedekind reals defined by +(** An interface for constructive and computable real numbers. + All of its instances are isomorphic (see file ConstructiveRealsMorphisms). + For example it contains the Cauchy reals implemented in file + ConstructivecauchyReals and the sumbool-based Dedekind reals defined by Structure R := { (* The cuts are represented as propositional functions, rather than subsets, @@ -41,7 +41,22 @@ Structure R := { see github.com/andrejbauer/dedekind-reals for the Prop-based version of those Dedekind reals (although Prop fails to make - them an instance of ConstructiveReals). *) + them an instance of ConstructiveReals). + + Any computation about constructive reals, can be worked + in the fastest instance for it; we then transport the results + to all other instances by the isomorphisms. This way of working + is different from the usual interfaces, where we would rather + prove things abstractly, by quantifying universally on the instance. + + The functions of ConstructiveReals do not have a direct impact + on performance, because algorithms will be extracted from instances, + and because fast ConstructiveReals morphisms should be coded + manually. However, since instances are forced to implement + those functions, it is probable that they will also use them + in their algorithms. So those functions hint at what we think + will yield fast and small extracted programs. *) + Require Import QArith. @@ -56,6 +71,9 @@ Definition orderEq (X : Set) (Xlt : X -> X -> Set) (x y : X) : Prop Definition orderAppart (X : Set) (Xlt : X -> X -> Set) (x y : X) : Set := Xlt x y + Xlt y x. +Definition orderLe (X : Set) (Xlt : X -> X -> Set) (x y : X) : Prop + := Xlt y x -> False. + Definition sig_forall_dec_T : Type := forall (P : nat -> Prop), (forall n, {P n} + {~P n}) -> {n | ~P n} + {forall n, P n}. @@ -65,9 +83,17 @@ Definition sig_not_dec_T : Type := forall P : Prop, { ~~P } + { ~P }. Record ConstructiveReals : Type := { CRcarrier : Set; + + (* Put this order relation in sort Set rather than Prop, + to allow the definition of fast ConstructiveReals morphisms. + For example, the Cauchy reals do store information in + the proofs of CRlt, which is used in algorithms in sort Set. *) CRlt : CRcarrier -> CRcarrier -> Set; CRltLinear : isLinearOrder CRcarrier CRlt; + (* The propositional truncation of CRlt. It facilitates proofs + when computations are not considered important, for example in + classical reals with extra logical axioms. *) CRltProp : CRcarrier -> CRcarrier -> Prop; (* This choice algorithm can be slow, keep it for the classical quotient of the reals, where computations are blocked by @@ -114,36 +140,696 @@ Record ConstructiveReals : Type := CRinv_0_lt_compat : forall (r : CRcarrier) (rnz : orderAppart _ CRlt r CRzero), CRlt CRzero r -> CRlt CRzero (CRinv r rnz); - CRarchimedean : forall x : CRcarrier, - { k : Z & CRlt x (gen_phiZ CRzero CRone CRplus CRmult CRopp k) }; + (* The initial field morphism (in characteristic zero). + The abstract definition by iteration of addition is + probably the slowest. Let each instance implement + a faster (and often simpler) version. *) + CR_of_Q : Q -> CRcarrier; + CR_of_Q_plus : forall q r : Q, orderEq _ CRlt (CR_of_Q (q+r)) + (CRplus (CR_of_Q q) (CR_of_Q r)); + CR_of_Q_mult : forall q r : Q, orderEq _ CRlt (CR_of_Q (q*r)) + (CRmult (CR_of_Q q) (CR_of_Q r)); + CR_of_Q_one : orderEq _ CRlt (CR_of_Q 1) CRone; + CR_of_Q_lt : forall q r : Q, + Qlt q r -> CRlt (CR_of_Q q) (CR_of_Q r); + lt_CR_of_Q : forall q r : Q, + CRlt (CR_of_Q q) (CR_of_Q r) -> Qlt q r; + + (* This function is very fast in both the Cauchy and Dedekind + instances, because this rational number q is almost what + the proof of CRlt x y contains. + This function is also the heart of the computation of + constructive real numbers : it approximates x to any + requested precision y. *) + CR_Q_dense : forall x y : CRcarrier, CRlt x y -> + { q : Q & prod (CRlt x (CR_of_Q q)) + (CRlt (CR_of_Q q) y) }; + CR_archimedean : forall x : CRcarrier, + { n : positive & CRlt x (CR_of_Q (Z.pos n # 1)) }; CRminus (x y : CRcarrier) : CRcarrier := CRplus x (CRopp y); + + (* Definitions of convergence and Cauchy-ness. The formulas + with orderLe or CRlt are logically equivalent, the choice of + orderLe in sort Prop is a question of performance. + It is very rare to turn back to the strict order to + define functions in sort Set, so we prefer to discard + those proofs during extraction. And even in those rare cases, + it is easy to divide epsilon by 2 for example. *) CR_cv (un : nat -> CRcarrier) (l : CRcarrier) : Set - := forall eps:CRcarrier, - CRlt CRzero eps - -> { p : nat & forall i:nat, le p i -> CRlt (CRopp eps) (CRminus (un i) l) - * CRlt (CRminus (un i) l) eps }; + := forall p:positive, + { n : nat | forall i:nat, le n i + -> orderLe _ CRlt (CR_of_Q (-1#p)) (CRminus (un i) l) + /\ orderLe _ CRlt (CRminus (un i) l) (CR_of_Q (1#p)) }; CR_cauchy (un : nat -> CRcarrier) : Set - := forall eps:CRcarrier, - CRlt CRzero eps - -> { p : nat & forall i j:nat, le p i -> le p j -> - CRlt (CRopp eps) (CRminus (un i) (un j)) - * CRlt (CRminus (un i) (un j)) eps }; + := forall p : positive, + { n : nat | forall i j:nat, le n i -> le n j + -> orderLe _ CRlt (CR_of_Q (-1#p)) (CRminus (un i) (un j)) + /\ orderLe _ CRlt (CRminus (un i) (un j)) (CR_of_Q (1#p)) }; + (* For the Cauchy reals, this algorithm consists in building + a Cauchy sequence of rationals un : nat -> Q that has + the same limit as xn. For each n:nat, un n is a 1/n + rational approximation of a point of xn that has converged + within 1/n. *) CR_complete : - forall xn : nat -> CRcarrier, CR_cauchy xn -> { l : CRcarrier & CR_cv xn l }; - - (* Those are redundant, they could be proved from the previous hypotheses *) - CRis_upper_bound (E:CRcarrier -> Prop) (m:CRcarrier) - := forall x:CRcarrier, E x -> CRlt m x -> False; - - CR_sig_lub : - forall (E:CRcarrier -> Prop), - sig_forall_dec_T - -> sig_not_dec_T - -> (exists x : CRcarrier, E x) - -> (exists x : CRcarrier, CRis_upper_bound E x) - -> { u : CRcarrier | CRis_upper_bound E u /\ - forall y:CRcarrier, CRis_upper_bound E y -> CRlt y u -> False }; + forall xn : (nat -> CRcarrier), + CR_cauchy xn -> { l : CRcarrier & CR_cv xn l }; }. + +Lemma CRlt_asym : forall (R : ConstructiveReals) (x y : CRcarrier R), + CRlt R x y -> CRlt R y x -> False. +Proof. + intros. destruct (CRltLinear R), p. + apply (f x y); assumption. +Qed. + +Lemma CRlt_proper + : forall R : ConstructiveReals, + CMorphisms.Proper + (CMorphisms.respectful (orderEq _ (CRlt R)) + (CMorphisms.respectful (orderEq _ (CRlt R)) CRelationClasses.iffT)) (CRlt R). +Proof. + intros R x y H x0 y0 H0. destruct H, H0. + destruct (CRltLinear R). split. + - intro. destruct (s x y x0). assumption. + contradiction. destruct (s y y0 x0). + assumption. assumption. contradiction. + - intro. destruct (s y x y0). assumption. + contradiction. destruct (s x x0 y0). + assumption. assumption. contradiction. +Qed. + +Lemma CRle_refl : forall (R : ConstructiveReals) (x : CRcarrier R), + CRlt R x x -> False. +Proof. + intros. destruct (CRltLinear R), p. + exact (f x x H H). +Qed. + +Lemma CRle_lt_trans : forall (R : ConstructiveReals) (r1 r2 r3 : CRcarrier R), + (CRlt R r2 r1 -> False) -> CRlt R r2 r3 -> CRlt R r1 r3. +Proof. + intros. destruct (CRltLinear R). + destruct (s r2 r1 r3 H0). contradiction. apply c. +Qed. + +Lemma CRlt_le_trans : forall (R : ConstructiveReals) (r1 r2 r3 : CRcarrier R), + CRlt R r1 r2 -> (CRlt R r3 r2 -> False) -> CRlt R r1 r3. +Proof. + intros. destruct (CRltLinear R). + destruct (s r1 r3 r2 H). apply c. contradiction. +Qed. + +Lemma CRle_trans : forall (R : ConstructiveReals) (x y z : CRcarrier R), + orderLe _ (CRlt R) x y -> orderLe _ (CRlt R) y z -> orderLe _ (CRlt R) x z. +Proof. + intros. intro abs. apply H0. + apply (CRlt_le_trans _ _ x); assumption. +Qed. + +Lemma CRlt_trans : forall (R : ConstructiveReals) (x y z : CRcarrier R), + CRlt R x y -> CRlt R y z -> CRlt R x z. +Proof. + intros. apply (CRlt_le_trans R _ y _ H). + apply CRlt_asym. exact H0. +Defined. + +Lemma CRlt_trans_flip : forall (R : ConstructiveReals) (x y z : CRcarrier R), + CRlt R y z -> CRlt R x y -> CRlt R x z. +Proof. + intros. apply (CRlt_le_trans R _ y). exact H0. + apply CRlt_asym. exact H. +Defined. + +Lemma CReq_refl : forall (R : ConstructiveReals) (x : CRcarrier R), + orderEq _ (CRlt R) x x. +Proof. + split; apply CRle_refl. +Qed. + +Lemma CReq_sym : forall (R : ConstructiveReals) (x y : CRcarrier R), + orderEq _ (CRlt R) x y + -> orderEq _ (CRlt R) y x. +Proof. + intros. destruct H. split; intro abs; contradiction. +Qed. + +Lemma CReq_trans : forall (R : ConstructiveReals) (x y z : CRcarrier R), + orderEq _ (CRlt R) x y + -> orderEq _ (CRlt R) y z + -> orderEq _ (CRlt R) x z. +Proof. + intros. destruct H,H0. destruct (CRltLinear R), p. split. + - intro abs. destruct (s _ y _ abs); contradiction. + - intro abs. destruct (s _ y _ abs); contradiction. +Qed. + +Lemma CR_setoid : forall R : ConstructiveReals, + Setoid_Theory (CRcarrier R) (orderEq _ (CRlt R)). +Proof. + split. intro x. apply CReq_refl. + intros x y. apply CReq_sym. + intros x y z. apply CReq_trans. +Qed. + +Lemma CRplus_0_r : forall (R : ConstructiveReals) (x : CRcarrier R), + orderEq _ (CRlt R) (CRplus R x (CRzero R)) x. +Proof. + intros. destruct (CRisRing R). + apply (CReq_trans R _ (CRplus R (CRzero R) x)). + apply Radd_comm. apply Radd_0_l. +Qed. + +Lemma CRmult_1_r : forall (R : ConstructiveReals) (x : CRcarrier R), + orderEq _ (CRlt R) (CRmult R x (CRone R)) x. +Proof. + intros. destruct (CRisRing R). + apply (CReq_trans R _ (CRmult R (CRone R) x)). + apply Rmul_comm. apply Rmul_1_l. +Qed. + +Lemma CRplus_opp_l : forall (R : ConstructiveReals) (x : CRcarrier R), + orderEq _ (CRlt R) (CRplus R (CRopp R x) x) (CRzero R). +Proof. + intros. destruct (CRisRing R). + apply (CReq_trans R _ (CRplus R x (CRopp R x))). + apply Radd_comm. apply Ropp_def. +Qed. + +Lemma CRplus_lt_compat_r : forall (R : ConstructiveReals) (r r1 r2 : CRcarrier R), + CRlt R r1 r2 -> CRlt R (CRplus R r1 r) (CRplus R r2 r). +Proof. + intros. destruct (CRisRing R). + apply (CRlt_proper R (CRplus R r r1) (CRplus R r1 r) (Radd_comm _ _) + (CRplus R r2 r) (CRplus R r2 r)). + apply CReq_refl. + apply (CRlt_proper R _ _ (CReq_refl _ _) _ (CRplus R r r2)). + apply Radd_comm. apply CRplus_lt_compat_l. exact H. +Qed. + +Lemma CRplus_lt_reg_r : forall (R : ConstructiveReals) (r r1 r2 : CRcarrier R), + CRlt R (CRplus R r1 r) (CRplus R r2 r) -> CRlt R r1 r2. +Proof. + intros. destruct (CRisRing R). + apply (CRlt_proper R (CRplus R r r1) (CRplus R r1 r) (Radd_comm _ _) + (CRplus R r2 r) (CRplus R r2 r)) in H. + 2: apply CReq_refl. + apply (CRlt_proper R _ _ (CReq_refl _ _) _ (CRplus R r r2)) in H. + apply CRplus_lt_reg_l in H. exact H. + apply Radd_comm. +Qed. + +Lemma CRplus_le_compat_l : forall (R : ConstructiveReals) (r r1 r2 : CRcarrier R), + orderLe _ (CRlt R) r1 r2 + -> orderLe _ (CRlt R) (CRplus R r r1) (CRplus R r r2). +Proof. + intros. intros abs. apply CRplus_lt_reg_l in abs. apply H. exact abs. +Qed. + +Lemma CRplus_le_compat_r : forall (R : ConstructiveReals) (r r1 r2 : CRcarrier R), + orderLe _ (CRlt R) r1 r2 + -> orderLe _ (CRlt R) (CRplus R r1 r) (CRplus R r2 r). +Proof. + intros. intros abs. apply CRplus_lt_reg_r in abs. apply H. exact abs. +Qed. + +Lemma CRplus_le_reg_l : forall (R : ConstructiveReals) (r r1 r2 : CRcarrier R), + orderLe _ (CRlt R) (CRplus R r r1) (CRplus R r r2) + -> orderLe _ (CRlt R) r1 r2. +Proof. + intros. intro abs. apply H. clear H. + apply CRplus_lt_compat_l. exact abs. +Qed. + +Lemma CRplus_le_reg_r : forall (R : ConstructiveReals) (r r1 r2 : CRcarrier R), + orderLe _ (CRlt R) (CRplus R r1 r) (CRplus R r2 r) + -> orderLe _ (CRlt R) r1 r2. +Proof. + intros. intro abs. apply H. clear H. + apply CRplus_lt_compat_r. exact abs. +Qed. + +Lemma CRplus_lt_le_compat : + forall (R : ConstructiveReals) (r1 r2 r3 r4 : CRcarrier R), + CRlt R r1 r2 + -> (CRlt R r4 r3 -> False) + -> CRlt R (CRplus R r1 r3) (CRplus R r2 r4). +Proof. + intros. apply (CRlt_le_trans R _ (CRplus R r2 r3)). + apply CRplus_lt_compat_r. exact H. intro abs. + apply CRplus_lt_reg_l in abs. contradiction. +Qed. + +Lemma CRplus_eq_reg_l : forall (R : ConstructiveReals) (r r1 r2 : CRcarrier R), + orderEq _ (CRlt R) (CRplus R r r1) (CRplus R r r2) + -> orderEq _ (CRlt R) r1 r2. +Proof. + intros. + destruct (CRisRingExt R). clear Rmul_ext Ropp_ext. + pose proof (Radd_ext + (CRopp R r) (CRopp R r) (CReq_refl _ _) + _ _ H). + destruct (CRisRing R). + apply (CReq_trans _ r1) in H0. + apply (CReq_trans R _ _ _ H0). + apply (CReq_trans R _ (CRplus R (CRplus R (CRopp R r) r) r2)). + apply Radd_assoc. + apply (CReq_trans R _ (CRplus R (CRzero R) r2)). + apply Radd_ext. apply CRplus_opp_l. apply CReq_refl. + apply Radd_0_l. apply CReq_sym. + apply (CReq_trans R _ (CRplus R (CRplus R (CRopp R r) r) r1)). + apply Radd_assoc. + apply (CReq_trans R _ (CRplus R (CRzero R) r1)). + apply Radd_ext. apply CRplus_opp_l. apply CReq_refl. + apply Radd_0_l. +Qed. + +Lemma CRplus_eq_reg_r : forall (R : ConstructiveReals) (r r1 r2 : CRcarrier R), + orderEq _ (CRlt R) (CRplus R r1 r) (CRplus R r2 r) + -> orderEq _ (CRlt R) r1 r2. +Proof. + intros. apply (CRplus_eq_reg_l R r). + apply (CReq_trans R _ (CRplus R r1 r)). apply (Radd_comm (CRisRing R)). + apply (CReq_trans R _ (CRplus R r2 r)). + exact H. apply (Radd_comm (CRisRing R)). +Qed. + +Lemma CRopp_involutive : forall (R : ConstructiveReals) (r : CRcarrier R), + orderEq _ (CRlt R) (CRopp R (CRopp R r)) r. +Proof. + intros. apply (CRplus_eq_reg_l R (CRopp R r)). + apply (CReq_trans R _ (CRzero R)). apply CRisRing. + apply CReq_sym, (CReq_trans R _ (CRplus R r (CRopp R r))). + apply CRisRing. apply CRisRing. +Qed. + +Lemma CRopp_gt_lt_contravar + : forall (R : ConstructiveReals) (r1 r2 : CRcarrier R), + CRlt R r2 r1 -> CRlt R (CRopp R r1) (CRopp R r2). +Proof. + intros. apply (CRplus_lt_reg_l R r1). + destruct (CRisRing R). + apply (CRle_lt_trans R _ (CRzero R)). apply Ropp_def. + apply (CRplus_lt_compat_l R (CRopp R r2)) in H. + apply (CRle_lt_trans R _ (CRplus R (CRopp R r2) r2)). + apply (CRle_trans R _ (CRplus R r2 (CRopp R r2))). + destruct (Ropp_def r2). exact H0. + destruct (Radd_comm r2 (CRopp R r2)). exact H1. + apply (CRlt_le_trans R _ _ _ H). + destruct (Radd_comm r1 (CRopp R r2)). exact H0. +Qed. + +Lemma CRopp_lt_cancel : forall (R : ConstructiveReals) (r1 r2 : CRcarrier R), + CRlt R (CRopp R r2) (CRopp R r1) -> CRlt R r1 r2. +Proof. + intros. apply (CRplus_lt_compat_r R r1) in H. + destruct (CRplus_opp_l R r1) as [_ H1]. + apply (CRlt_le_trans R _ _ _ H) in H1. clear H. + apply (CRplus_lt_compat_l R r2) in H1. + destruct (CRplus_0_r R r2) as [_ H0]. + apply (CRlt_le_trans R _ _ _ H1) in H0. clear H1. + destruct (Radd_assoc (CRisRing R) r2 (CRopp R r2) r1) as [H _]. + apply (CRle_lt_trans R _ _ _ H) in H0. clear H. + apply (CRle_lt_trans R _ (CRplus R (CRzero R) r1)). + apply (Radd_0_l (CRisRing R)). + apply (CRle_lt_trans R _ (CRplus R (CRplus R r2 (CRopp R r2)) r1)). + 2: exact H0. apply CRplus_le_compat_r. + destruct (Ropp_def (CRisRing R) r2). exact H. +Qed. + +Lemma CRopp_plus_distr : forall (R : ConstructiveReals) (r1 r2 : CRcarrier R), + orderEq _ (CRlt R) (CRopp R (CRplus R r1 r2)) (CRplus R (CRopp R r1) (CRopp R r2)). +Proof. + intros. destruct (CRisRing R), (CRisRingExt R). + apply (CRplus_eq_reg_l R (CRplus R r1 r2)). + apply (CReq_trans R _ (CRzero R)). apply Ropp_def. + apply (CReq_trans R _ (CRplus R (CRplus R r2 r1) (CRplus R (CRopp R r1) (CRopp R r2)))). + apply (CReq_trans R _ (CRplus R r2 (CRplus R r1 (CRplus R (CRopp R r1) (CRopp R r2))))). + apply (CReq_trans R _ (CRplus R r2 (CRopp R r2))). + apply CReq_sym. apply Ropp_def. apply Radd_ext. + apply CReq_refl. + apply (CReq_trans R _ (CRplus R (CRzero R) (CRopp R r2))). + apply CReq_sym, Radd_0_l. + apply (CReq_trans R _ (CRplus R (CRplus R r1 (CRopp R r1)) (CRopp R r2))). + apply Radd_ext. 2: apply CReq_refl. apply CReq_sym, Ropp_def. + apply CReq_sym, Radd_assoc. apply Radd_assoc. + apply Radd_ext. 2: apply CReq_refl. apply Radd_comm. +Qed. + +Lemma CRmult_plus_distr_l : forall (R : ConstructiveReals) (r1 r2 r3 : CRcarrier R), + orderEq _ (CRlt R) (CRmult R r1 (CRplus R r2 r3)) + (CRplus R (CRmult R r1 r2) (CRmult R r1 r3)). +Proof. + intros. destruct (CRisRing R). + apply (CReq_trans R _ (CRmult R (CRplus R r2 r3) r1)). + apply Rmul_comm. + apply (CReq_trans R _ (CRplus R (CRmult R r2 r1) (CRmult R r3 r1))). + apply Rdistr_l. + apply (CReq_trans R _ (CRplus R (CRmult R r1 r2) (CRmult R r3 r1))). + destruct (CRisRingExt R). apply Radd_ext. + apply Rmul_comm. apply CReq_refl. + destruct (CRisRingExt R). apply Radd_ext. + apply CReq_refl. apply Rmul_comm. +Qed. + +(* x == x+x -> x == 0 *) +Lemma CRzero_double : forall (R : ConstructiveReals) (x : CRcarrier R), + orderEq _ (CRlt R) x (CRplus R x x) + -> orderEq _ (CRlt R) x (CRzero R). +Proof. + intros. + apply (CRplus_eq_reg_l R x), CReq_sym, (CReq_trans R _ x). + apply CRplus_0_r. exact H. +Qed. + +Lemma CRmult_0_r : forall (R : ConstructiveReals) (x : CRcarrier R), + orderEq _ (CRlt R) (CRmult R x (CRzero R)) (CRzero R). +Proof. + intros. apply CRzero_double. + apply (CReq_trans R _ (CRmult R x (CRplus R (CRzero R) (CRzero R)))). + destruct (CRisRingExt R). apply Rmul_ext. apply CReq_refl. + apply CReq_sym, CRplus_0_r. + destruct (CRisRing R). apply CRmult_plus_distr_l. +Qed. + +Lemma CRopp_mult_distr_r : forall (R : ConstructiveReals) (r1 r2 : CRcarrier R), + orderEq _ (CRlt R) (CRopp R (CRmult R r1 r2)) + (CRmult R r1 (CRopp R r2)). +Proof. + intros. apply (CRplus_eq_reg_l R (CRmult R r1 r2)). + destruct (CRisRing R). + apply (CReq_trans R _ (CRzero R)). apply Ropp_def. + apply (CReq_trans R _ (CRmult R r1 (CRplus R r2 (CRopp R r2)))). + 2: apply CRmult_plus_distr_l. + apply (CReq_trans R _ (CRmult R r1 (CRzero R))). + apply CReq_sym, CRmult_0_r. + destruct (CRisRingExt R). apply Rmul_ext. apply CReq_refl. + apply CReq_sym, Ropp_def. +Qed. + +Lemma CRopp_mult_distr_l : forall (R : ConstructiveReals) (r1 r2 : CRcarrier R), + orderEq _ (CRlt R) (CRopp R (CRmult R r1 r2)) + (CRmult R (CRopp R r1) r2). +Proof. + intros. apply (CReq_trans R _ (CRmult R r2 (CRopp R r1))). + apply (CReq_trans R _ (CRopp R (CRmult R r2 r1))). + apply (Ropp_ext (CRisRingExt R)). + apply CReq_sym, (Rmul_comm (CRisRing R)). + apply CRopp_mult_distr_r. + apply CReq_sym, (Rmul_comm (CRisRing R)). +Qed. + +Lemma CRmult_lt_compat_r : forall (R : ConstructiveReals) (r r1 r2 : CRcarrier R), + CRlt R (CRzero R) r + -> CRlt R r1 r2 + -> CRlt R (CRmult R r1 r) (CRmult R r2 r). +Proof. + intros. apply (CRplus_lt_reg_r R (CRopp R (CRmult R r1 r))). + apply (CRle_lt_trans R _ (CRzero R)). + apply (Ropp_def (CRisRing R)). + apply (CRlt_le_trans R _ (CRplus R (CRmult R r2 r) (CRmult R (CRopp R r1) r))). + apply (CRlt_le_trans R _ (CRmult R (CRplus R r2 (CRopp R r1)) r)). + apply CRmult_lt_0_compat. 2: exact H. + apply (CRplus_lt_reg_r R r1). + apply (CRle_lt_trans R _ r1). apply (Radd_0_l (CRisRing R)). + apply (CRlt_le_trans R _ r2 _ H0). + apply (CRle_trans R _ (CRplus R r2 (CRplus R (CRopp R r1) r1))). + apply (CRle_trans R _ (CRplus R r2 (CRzero R))). + destruct (CRplus_0_r R r2). exact H1. + apply CRplus_le_compat_l. destruct (CRplus_opp_l R r1). exact H1. + destruct (Radd_assoc (CRisRing R) r2 (CRopp R r1) r1). exact H2. + destruct (CRisRing R). + destruct (Rdistr_l r2 (CRopp R r1) r). exact H2. + apply CRplus_le_compat_l. destruct (CRopp_mult_distr_l R r1 r). + exact H1. +Qed. + +Lemma CRinv_r : forall (R : ConstructiveReals) (r:CRcarrier R) + (rnz : orderAppart _ (CRlt R) r (CRzero R)), + orderEq _ (CRlt R) (CRmult R r (CRinv R r rnz)) (CRone R). +Proof. + intros. apply (CReq_trans R _ (CRmult R (CRinv R r rnz) r)). + apply (CRisRing R). apply CRinv_l. +Qed. + +Lemma CRmult_lt_reg_r : forall (R : ConstructiveReals) (r r1 r2 : CRcarrier R), + CRlt R (CRzero R) r + -> CRlt R (CRmult R r1 r) (CRmult R r2 r) + -> CRlt R r1 r2. +Proof. + intros. apply (CRmult_lt_compat_r R (CRinv R r (inr H))) in H0. + 2: apply CRinv_0_lt_compat, H. + apply (CRle_lt_trans R _ (CRmult R (CRmult R r1 r) (CRinv R r (inr H)))). + - clear H0. apply (CRle_trans R _ (CRmult R r1 (CRone R))). + destruct (CRmult_1_r R r1). exact H0. + apply (CRle_trans R _ (CRmult R r1 (CRmult R r (CRinv R r (inr H))))). + destruct (Rmul_ext (CRisRingExt R) r1 r1 (CReq_refl R r1) + (CRmult R r (CRinv R r (inr H))) (CRone R)). + apply CRinv_r. exact H0. + destruct (Rmul_assoc (CRisRing R) r1 r (CRinv R r (inr H))). exact H1. + - apply (CRlt_le_trans R _ (CRmult R (CRmult R r2 r) (CRinv R r (inr H)))). + exact H0. clear H0. + apply (CRle_trans R _ (CRmult R r2 (CRone R))). + 2: destruct (CRmult_1_r R r2); exact H1. + apply (CRle_trans R _ (CRmult R r2 (CRmult R r (CRinv R r (inr H))))). + destruct (Rmul_assoc (CRisRing R) r2 r (CRinv R r (inr H))). exact H0. + destruct (Rmul_ext (CRisRingExt R) r2 r2 (CReq_refl R r2) + (CRmult R r (CRinv R r (inr H))) (CRone R)). + apply CRinv_r. exact H1. +Qed. + +Lemma CRmult_lt_reg_l : forall (R : ConstructiveReals) (r r1 r2 : CRcarrier R), + CRlt R (CRzero R) r + -> CRlt R (CRmult R r r1) (CRmult R r r2) + -> CRlt R r1 r2. +Proof. + intros. + destruct (Rmul_comm (CRisRing R) r r1) as [H1 _]. + apply (CRle_lt_trans R _ _ _ H1) in H0. clear H1. + destruct (Rmul_comm (CRisRing R) r r2) as [_ H1]. + apply (CRlt_le_trans R _ _ _ H0) in H1. clear H0. + apply CRmult_lt_reg_r in H1. + exact H1. exact H. +Qed. + +Lemma CRmult_le_compat_l : forall (R : ConstructiveReals) (r r1 r2 : CRcarrier R), + CRlt R (CRzero R) r + -> orderLe _ (CRlt R) r1 r2 + -> orderLe _ (CRlt R) (CRmult R r r1) (CRmult R r r2). +Proof. + intros. intro abs. apply CRmult_lt_reg_l in abs. + contradiction. exact H. +Qed. + +Lemma CRmult_le_compat_r : forall (R : ConstructiveReals) (r r1 r2 : CRcarrier R), + CRlt R (CRzero R) r + -> orderLe _ (CRlt R) r1 r2 + -> orderLe _ (CRlt R) (CRmult R r1 r) (CRmult R r2 r). +Proof. + intros. intro abs. apply CRmult_lt_reg_r in abs. + contradiction. exact H. +Qed. + +Lemma CRmult_eq_reg_r : forall (R : ConstructiveReals) (r r1 r2 : CRcarrier R), + orderAppart _ (CRlt R) (CRzero R) r + -> orderEq _ (CRlt R) (CRmult R r1 r) (CRmult R r2 r) + -> orderEq _ (CRlt R) r1 r2. +Proof. + intros. destruct H0,H. + - split. + + intro abs. apply H0. apply CRmult_lt_compat_r. + exact c. exact abs. + + intro abs. apply H1. apply CRmult_lt_compat_r. + exact c. exact abs. + - split. + + intro abs. apply H1. apply CRopp_lt_cancel. + apply (CRle_lt_trans R _ (CRmult R r1 (CRopp R r))). + apply CRopp_mult_distr_r. + apply (CRlt_le_trans R _ (CRmult R r2 (CRopp R r))). + 2: apply CRopp_mult_distr_r. + apply CRmult_lt_compat_r. 2: exact abs. + apply (CRplus_lt_reg_r R r). apply (CRle_lt_trans R _ r). + apply (Radd_0_l (CRisRing R)). + apply (CRlt_le_trans R _ (CRzero R) _ c). + apply CRplus_opp_l. + + intro abs. apply H0. apply CRopp_lt_cancel. + apply (CRle_lt_trans R _ (CRmult R r2 (CRopp R r))). + apply CRopp_mult_distr_r. + apply (CRlt_le_trans R _ (CRmult R r1 (CRopp R r))). + 2: apply CRopp_mult_distr_r. + apply CRmult_lt_compat_r. 2: exact abs. + apply (CRplus_lt_reg_r R r). apply (CRle_lt_trans R _ r). + apply (Radd_0_l (CRisRing R)). + apply (CRlt_le_trans R _ (CRzero R) _ c). + apply CRplus_opp_l. +Qed. + +Lemma CR_of_Q_proper : forall (R : ConstructiveReals) (q r : Q), + q == r -> orderEq _ (CRlt R) (CR_of_Q R q) (CR_of_Q R r). +Proof. + split. + - intro abs. apply lt_CR_of_Q in abs. rewrite H in abs. + exact (Qlt_not_le r r abs (Qle_refl r)). + - intro abs. apply lt_CR_of_Q in abs. rewrite H in abs. + exact (Qlt_not_le r r abs (Qle_refl r)). +Qed. + +Lemma CR_of_Q_zero : forall (R : ConstructiveReals), + orderEq _ (CRlt R) (CR_of_Q R 0) (CRzero R). +Proof. + intros. apply CRzero_double. + apply (CReq_trans R _ (CR_of_Q R (0+0))). apply CR_of_Q_proper. + reflexivity. apply CR_of_Q_plus. +Qed. + +Lemma CR_of_Q_opp : forall (R : ConstructiveReals) (q : Q), + orderEq _ (CRlt R) (CR_of_Q R (-q)) (CRopp R (CR_of_Q R q)). +Proof. + intros. apply (CRplus_eq_reg_l R (CR_of_Q R q)). + apply (CReq_trans R _ (CRzero R)). + apply (CReq_trans R _ (CR_of_Q R (q-q))). + apply CReq_sym, CR_of_Q_plus. + apply (CReq_trans R _ (CR_of_Q R 0)). + apply CR_of_Q_proper. ring. apply CR_of_Q_zero. + apply CReq_sym. apply (CRisRing R). +Qed. + +Lemma CR_of_Q_le : forall (R : ConstructiveReals) (r q : Q), + Qle r q + -> orderLe _ (CRlt R) (CR_of_Q R r) (CR_of_Q R q). +Proof. + intros. intro abs. apply lt_CR_of_Q in abs. + exact (Qlt_not_le _ _ abs H). +Qed. + +Lemma CR_of_Q_pos : forall (R : ConstructiveReals) (q:Q), + Qlt 0 q -> CRlt R (CRzero R) (CR_of_Q R q). +Proof. + intros. apply (CRle_lt_trans R _ (CR_of_Q R 0)). + apply CR_of_Q_zero. apply CR_of_Q_lt. exact H. +Qed. + +Lemma CR_cv_above_rat + : forall (R : ConstructiveReals) (xn : nat -> Q) (x : CRcarrier R) (q : Q), + CR_cv R (fun n : nat => CR_of_Q R (xn n)) x + -> CRlt R (CR_of_Q R q) x + -> { n : nat | forall p:nat, le n p -> Qlt q (xn p) }. +Proof. + intros. + destruct (CR_Q_dense R _ _ H0) as [r [H1 H2]]. + apply lt_CR_of_Q in H1. clear H0. + destruct (Qarchimedean (/(r-q))) as [p pmaj]. + destruct (H p) as [n nmaj]. + exists n. intros k lenk. specialize (nmaj k lenk) as [H3 _]. + apply (lt_CR_of_Q R), (CRlt_le_trans R _ (CRplus R x (CR_of_Q R (-1#p)))). + apply (CRlt_trans R _ (CRplus R (CR_of_Q R r) (CR_of_Q R (-1#p)))). + 2: apply CRplus_lt_compat_r, H2. + apply (CRlt_le_trans R _ (CR_of_Q R (r+(-1#p)))). + - apply CR_of_Q_lt. + apply (Qplus_lt_l _ _ (-(-1#p)-q)). field_simplify. + setoid_replace (-1*(-1#p)) with (1#p). 2: reflexivity. + apply (Qmult_lt_l _ _ (r-q)) in pmaj. + rewrite Qmult_inv_r in pmaj. apply Qlt_shift_div_r in pmaj. + 2: reflexivity. setoid_replace (-1*q + r) with (r-q). exact pmaj. + ring. intro abs. apply Qlt_minus_iff in H1. + rewrite abs in H1. inversion H1. + apply Qlt_minus_iff in H1. exact H1. + - apply CR_of_Q_plus. + - apply (CRplus_le_reg_r R (CRopp R x)). + apply (CRle_trans R _ (CR_of_Q R (-1#p))). 2: exact H3. clear H3. + apply (CRle_trans R _ (CRplus R (CRopp R x) (CRplus R x (CR_of_Q R (-1 # p))))). + exact (proj1 (Radd_comm (CRisRing R) _ _)). + apply (CRle_trans R _ (CRplus R (CRplus R (CRopp R x) x) (CR_of_Q R (-1 # p)))). + exact (proj2 (Radd_assoc (CRisRing R) _ _ _)). + apply (CRle_trans R _ (CRplus R (CRzero R) (CR_of_Q R (-1 # p)))). + apply CRplus_le_compat_r. exact (proj2 (CRplus_opp_l R _)). + exact (proj2 (Radd_0_l (CRisRing R) _)). +Qed. + +Lemma CR_cv_below_rat + : forall (R : ConstructiveReals) (xn : nat -> Q) (x : CRcarrier R) (q : Q), + CR_cv R (fun n : nat => CR_of_Q R (xn n)) x + -> CRlt R x (CR_of_Q R q) + -> { n : nat | forall p:nat, le n p -> Qlt (xn p) q }. +Proof. + intros. + destruct (CR_Q_dense R _ _ H0) as [r [H1 H2]]. + apply lt_CR_of_Q in H2. clear H0. + destruct (Qarchimedean (/(q-r))) as [p pmaj]. + destruct (H p) as [n nmaj]. + exists n. intros k lenk. specialize (nmaj k lenk) as [_ H4]. + apply (lt_CR_of_Q R), (CRle_lt_trans R _ (CRplus R x (CR_of_Q R (1#p)))). + - apply (CRplus_le_reg_r R (CRopp R x)). + apply (CRle_trans R _ (CR_of_Q R (1#p))). exact H4. clear H4. + apply (CRle_trans R _ (CRplus R (CRopp R x) (CRplus R x (CR_of_Q R (1 # p))))). + 2: exact (proj1 (Radd_comm (CRisRing R) _ _)). + apply (CRle_trans R _ (CRplus R (CRplus R (CRopp R x) x) (CR_of_Q R (1 # p)))). + 2: exact (proj1 (Radd_assoc (CRisRing R) _ _ _)). + apply (CRle_trans R _ (CRplus R (CRzero R) (CR_of_Q R (1 # p)))). + exact (proj1 (Radd_0_l (CRisRing R) _)). + apply CRplus_le_compat_r. exact (proj1 (CRplus_opp_l R _)). + - apply (CRlt_trans R _ (CRplus R (CR_of_Q R r) (CR_of_Q R (1 # p)))). + apply CRplus_lt_compat_r. exact H1. + apply (CRle_lt_trans R _ (CR_of_Q R (r + (1#p)))). + apply CR_of_Q_plus. apply CR_of_Q_lt. + apply (Qmult_lt_l _ _ (q-r)) in pmaj. + rewrite Qmult_inv_r in pmaj. apply Qlt_shift_div_r in pmaj. + apply (Qplus_lt_l _ _ (-r)). field_simplify. + setoid_replace (-1*r + q) with (q-r). exact pmaj. + ring. reflexivity. intro abs. apply Qlt_minus_iff in H2. + rewrite abs in H2. inversion H2. + apply Qlt_minus_iff in H2. exact H2. +Qed. + +Lemma CR_cv_const : forall (R : ConstructiveReals) (x y : CRcarrier R), + CR_cv R (fun _ => x) y -> orderEq _ (CRlt R) x y. +Proof. + intros. destruct (CRisRing R). split. + - intro abs. + destruct (CR_Q_dense R x y abs) as [q [H0 H1]]. + destruct (CR_Q_dense R _ _ H1) as [r [H2 H3]]. + apply lt_CR_of_Q in H2. + destruct (Qarchimedean (/(r-q))) as [p pmaj]. + destruct (H p) as [n nmaj]. specialize (nmaj n (le_refl n)) as [nmaj _]. + apply nmaj. clear nmaj. + apply (CRlt_trans R _ (CR_of_Q R (q-r))). + apply (CRlt_le_trans R _ (CRplus R (CR_of_Q R q) (CRopp R (CR_of_Q R r)))). + + apply CRplus_lt_le_compat. exact H0. + intro H4. apply CRopp_lt_cancel in H4. exact (CRlt_asym R _ _ H4 H3). + + apply (CRle_trans R _ (CRplus R (CR_of_Q R q) (CR_of_Q R (-r)))). + apply CRplus_le_compat_l. exact (proj1 (CR_of_Q_opp R r)). + exact (proj1 (CR_of_Q_plus R _ _)). + + apply CR_of_Q_lt. + apply (Qplus_lt_l _ _ (-(-1#p)+r-q)). field_simplify. + setoid_replace (-1*(-1#p)) with (1#p). 2: reflexivity. + apply (Qmult_lt_l _ _ (r-q)) in pmaj. + rewrite Qmult_inv_r in pmaj. apply Qlt_shift_div_r in pmaj. + 2: reflexivity. setoid_replace (-1*q + r) with (r-q). exact pmaj. + ring. intro H4. apply Qlt_minus_iff in H2. + rewrite H4 in H2. inversion H2. + apply Qlt_minus_iff in H2. exact H2. + - intro abs. + destruct (CR_Q_dense R _ _ abs) as [q [H0 H1]]. + destruct (CR_Q_dense R _ _ H0) as [r [H2 H3]]. + apply lt_CR_of_Q in H3. + destruct (Qarchimedean (/(q-r))) as [p pmaj]. + destruct (H p) as [n nmaj]. specialize (nmaj n (le_refl n)) as [_ nmaj]. + apply nmaj. clear nmaj. + apply (CRlt_trans R _ (CR_of_Q R (q-r))). + + apply CR_of_Q_lt. + apply (Qmult_lt_l _ _ (q-r)) in pmaj. + rewrite Qmult_inv_r in pmaj. apply Qlt_shift_div_r in pmaj. + exact pmaj. reflexivity. + intro H4. apply Qlt_minus_iff in H3. + rewrite H4 in H3. inversion H3. + apply Qlt_minus_iff in H3. exact H3. + + apply (CRle_lt_trans R _ (CRplus R (CR_of_Q R q) (CR_of_Q R (-r)))). + apply CR_of_Q_plus. + apply (CRle_lt_trans R _ (CRplus R (CR_of_Q R q) (CRopp R (CR_of_Q R r)))). + apply CRplus_le_compat_l. exact (proj2 (CR_of_Q_opp R r)). + apply CRplus_lt_le_compat. exact H1. + intro H4. apply CRopp_lt_cancel in H4. + exact (CRlt_asym R _ _ H4 H2). +Qed. diff --git a/theories/Reals/ConstructiveRealsLUB.v b/theories/Reals/ConstructiveRealsLUB.v index f5c447f7db..3a26b8cefb 100644 --- a/theories/Reals/ConstructiveRealsLUB.v +++ b/theories/Reals/ConstructiveRealsLUB.v @@ -15,7 +15,9 @@ Require Import QArith_base. Require Import Qabs. -Require Import ConstructiveCauchyReals. +Require Import ConstructiveReals. +Require Import ConstructiveCauchyRealsMult. +Require Import ConstructiveRealsMorphisms. Require Import ConstructiveRcomplete. Require Import Logic.ConstructiveEpsilon. @@ -54,14 +56,15 @@ Lemma is_upper_bound_epsilon : sig_forall_dec_T -> sig_not_dec_T -> (exists x:CReal, is_upper_bound E x) - -> { n:nat | is_upper_bound E (INR n) }. + -> { n:nat | is_upper_bound E (inject_Q (Z.of_nat n # 1)) }. Proof. intros E lpo sig_not_dec Ebound. apply constructive_indefinite_ground_description_nat. - intro n. apply is_upper_bound_dec. exact lpo. exact sig_not_dec. - - destruct Ebound as [x H]. destruct (Rup_nat x). exists x0. + - destruct Ebound as [x H]. destruct (Rup_pos x). exists (Pos.to_nat x0). intros y ey. specialize (H y ey). - apply CRealLt_asym. apply (CRealLe_Lt_trans _ x); assumption. + apply CRealLt_asym. apply (CReal_le_lt_trans _ x). + exact H. rewrite positive_nat_Z. exact c. Qed. Lemma is_upper_bound_not_epsilon : @@ -69,15 +72,16 @@ Lemma is_upper_bound_not_epsilon : sig_forall_dec_T -> sig_not_dec_T -> (exists x : CReal, E x) - -> { m:nat | ~is_upper_bound E (-INR m) }. + -> { m:nat | ~is_upper_bound E (-inject_Q (Z.of_nat m # 1)) }. Proof. intros E lpo sig_not_dec H. apply constructive_indefinite_ground_description_nat. - - intro n. destruct (is_upper_bound_dec E (-INR n) lpo sig_not_dec). + - intro n. destruct (is_upper_bound_dec E (-inject_Q (Z.of_nat n # 1)) lpo sig_not_dec). right. intro abs. contradiction. left. exact n0. - - destruct H as [x H]. destruct (Rup_nat (-x)) as [n H0]. - exists n. intro abs. specialize (abs x H). - apply abs. apply (CReal_plus_lt_reg_l (INR n-x)). + - destruct H as [x H]. destruct (Rup_pos (-x)) as [n H0]. + exists (Pos.to_nat n). intro abs. specialize (abs x H). + apply abs. rewrite positive_nat_Z. + apply (CReal_plus_lt_reg_l (inject_Q (Z.pos n # 1)-x)). ring_simplify. exact H0. Qed. @@ -140,8 +144,8 @@ Proof. Qed. Lemma glb_dec_Q : forall upcut : DedekindDecCut, - { x : CReal | forall r:Q, (x < IQR r -> DDupcut upcut r) - /\ (IQR r < x -> ~DDupcut upcut r) }. + { x : CReal | forall r:Q, (x < inject_Q r -> DDupcut upcut r) + /\ (inject_Q r < x -> ~DDupcut upcut r) }. Proof. intros. assert (forall a b : Q, Qle a b -> Qle (-b) (-a)). @@ -175,7 +179,7 @@ Proof. pose (exist (fun qn => QSeqEquiv qn qn Pos.to_nat) _ H0) as l. exists l. split. - intros. (* find an upper point between the limit and r *) - rewrite FinjectQ_CReal in H1. destruct H1 as [p pmaj]. + destruct H1 as [p pmaj]. unfold l,proj1_sig in pmaj. destruct (DDcut_limit upcut (1 # Pos.of_nat (Pos.to_nat p)) eq_refl) as [q qmaj] ; simpl in pmaj. @@ -184,8 +188,7 @@ Proof. apply (Qle_trans _ ((2#p) + q)). apply (Qplus_le_l _ _ (-q)). ring_simplify. discriminate. apply Qlt_le_weak. exact pmaj. - - intros H1 abs. - rewrite FinjectQ_CReal in H1. destruct H1 as [p pmaj]. + - intros [p pmaj] abs. unfold l,proj1_sig in pmaj. destruct (DDcut_limit upcut (1 # Pos.of_nat (Pos.to_nat p)) eq_refl) as [q qmaj] ; simpl in pmaj. @@ -205,26 +208,24 @@ Lemma is_upper_bound_glb : -> sig_forall_dec_T -> (exists x : CReal, E x) -> (exists x : CReal, is_upper_bound E x) - -> { x : CReal | forall r:Q, (x < IQR r -> is_upper_bound E (IQR r)) - /\ (IQR r < x -> ~is_upper_bound E (IQR r)) }. + -> { x : CReal | forall r:Q, (x < inject_Q r -> is_upper_bound E (inject_Q r)) + /\ (inject_Q r < x -> ~is_upper_bound E (inject_Q r)) }. Proof. intros E sig_not_dec lpo Einhab Ebound. destruct (is_upper_bound_epsilon E lpo sig_not_dec Ebound) as [a luba]. destruct (is_upper_bound_not_epsilon E lpo sig_not_dec Einhab) as [b glbb]. - pose (fun q => is_upper_bound E (IQR q)) as upcut. + pose (fun q => is_upper_bound E (inject_Q q)) as upcut. assert (forall q:Q, { upcut q } + { ~upcut q } ). { intro q. apply is_upper_bound_dec. exact lpo. exact sig_not_dec. } assert (forall q r : Q, (q <= r)%Q -> upcut q -> upcut r). { intros. intros x Ex. specialize (H1 x Ex). intro abs. - apply H1. apply (CRealLe_Lt_trans _ (IQR r)). 2: exact abs. - apply IQR_le. exact H0. } + apply H1. apply (CReal_le_lt_trans _ (inject_Q r)). 2: exact abs. + apply inject_Q_le. exact H0. } assert (upcut (Z.of_nat a # 1)%Q). - { intros x Ex. unfold IQR. rewrite CReal_inv_1, CReal_mult_1_r. - specialize (luba x Ex). rewrite <- INR_IZR_INZ. exact luba. } + { intros x Ex. exact (luba x Ex). } assert (~upcut (- Z.of_nat b # 1)%Q). { intros abs. apply glbb. intros x Ex. - specialize (abs x Ex). unfold IQR in abs. - rewrite CReal_inv_1, CReal_mult_1_r, opp_IZR, <- INR_IZR_INZ in abs. + specialize (abs x Ex). rewrite <- opp_inject_Q. exact abs. } assert (forall q r : Q, (q == r)%Q -> upcut q -> upcut r). { intros. intros x Ex. specialize (H4 x Ex). rewrite <- H3. exact H4. } @@ -257,7 +258,7 @@ Proof. intro abs. destruct (FQ_dense b x abs) as [q [qmaj H0]]. specialize (a q) as [_ a]. apply a. exact H0. intros y Ey. specialize (H y Ey). intro abs2. - apply H. exact (CRealLt_trans _ (IQR q) _ qmaj abs2). + apply H. exact (CReal_lt_trans _ (inject_Q q) _ qmaj abs2). Qed. Lemma sig_lub : @@ -274,3 +275,44 @@ Proof. E sig_not_dec sig_forall_dec Einhab Ebound); simpl in H. exists x. exact H. Qed. + +Definition CRis_upper_bound (R : ConstructiveReals) (E:CRcarrier R -> Prop) (m:CRcarrier R) + := forall x:CRcarrier R, E x -> CRlt R m x -> False. + +Lemma CR_sig_lub : + forall (R : ConstructiveReals) (E:CRcarrier R -> Prop), + (forall x y : CRcarrier R, orderEq _ (CRlt R) x y -> (E x <-> E y)) + -> sig_forall_dec_T + -> sig_not_dec_T + -> (exists x : CRcarrier R, E x) + -> (exists x : CRcarrier R, CRis_upper_bound R E x) + -> { u : CRcarrier R | CRis_upper_bound R E u /\ + forall y:CRcarrier R, CRis_upper_bound R E y -> CRlt R y u -> False }. +Proof. + intros. destruct (sig_lub (fun x:CReal => E (CauchyMorph R x)) X X0) as [u ulub]. + - destruct H0. exists (CauchyMorph_inv R x). + specialize (H (CauchyMorph R (CauchyMorph_inv R x)) x + (CauchyMorph_surject R x)) as [_ H]. + exact (H H0). + - destruct H1. exists (CauchyMorph_inv R x). + intros y Ey. specialize (H1 (CauchyMorph R y) Ey). + intros abs. apply H1. + apply (CauchyMorph_increasing R) in abs. + apply (CRle_lt_trans R _ (CauchyMorph R (CauchyMorph_inv R x))). + 2: exact abs. apply (CauchyMorph_surject R x). + - exists (CauchyMorph R u). destruct ulub. split. + + intros y Ey abs. specialize (H2 (CauchyMorph_inv R y)). + simpl in H2. + specialize (H (CauchyMorph R (CauchyMorph_inv R y)) y + (CauchyMorph_surject R y)) as [_ H]. + specialize (H2 (H Ey)). apply H2. + apply CauchyMorph_inv_increasing in abs. + rewrite CauchyMorph_inject in abs. exact abs. + + intros. apply (H3 (CauchyMorph_inv R y)). + intros z Ez abs. specialize (H4 (CauchyMorph R z)). + apply (H4 Ez). apply (CauchyMorph_increasing R) in abs. + apply (CRle_lt_trans R _ (CauchyMorph R (CauchyMorph_inv R y))). + 2: exact abs. apply (CauchyMorph_surject R y). + apply CauchyMorph_inv_increasing in H5. + rewrite CauchyMorph_inject in H5. exact H5. +Qed. diff --git a/theories/Reals/ConstructiveRealsMorphisms.v b/theories/Reals/ConstructiveRealsMorphisms.v new file mode 100644 index 0000000000..0d3027d475 --- /dev/null +++ b/theories/Reals/ConstructiveRealsMorphisms.v @@ -0,0 +1,1158 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) +(************************************************************************) + +(** Morphisms used to transport results from any instance of + ConstructiveReals to any other. + Between any two constructive reals structures R1 and R2, + all morphisms R1 -> R2 are extensionally equal. We will + further show that they exist, and so are isomorphisms. + The difference between two morphisms R1 -> R2 is therefore + the speed of computation. + + The canonical isomorphisms we provide here are often very slow, + when a new implementation of constructive reals is added, + it should define its own ad hoc isomorphisms for better speed. + + Apart from the speed, those unique isomorphisms also serve as + sanity checks of the interface ConstructiveReals : + it captures a concept with a strong notion of uniqueness. *) + +Require Import QArith. +Require Import Qabs. +Require Import ConstructiveReals. +Require Import ConstructiveCauchyRealsMult. +Require Import ConstructiveRIneq. + + +Record ConstructiveRealsMorphism (R1 R2 : ConstructiveReals) : Set := + { + CRmorph : CRcarrier R1 -> CRcarrier R2; + CRmorph_rat : forall q : Q, + orderEq _ (CRlt R2) (CRmorph (CR_of_Q R1 q)) (CR_of_Q R2 q); + CRmorph_increasing : forall x y : CRcarrier R1, + CRlt R1 x y -> CRlt R2 (CRmorph x) (CRmorph y); + }. + + +Lemma CRmorph_increasing_inv + : forall (R1 R2 : ConstructiveReals) + (f : ConstructiveRealsMorphism R1 R2) + (x y : CRcarrier R1), + CRlt R2 (CRmorph _ _ f x) (CRmorph _ _ f y) + -> CRlt R1 x y. +Proof. + intros. destruct (CR_Q_dense R2 _ _ H) as [q [H0 H1]]. + destruct (CR_Q_dense R2 _ _ H0) as [r [H2 H3]]. + apply lt_CR_of_Q, (CR_of_Q_lt R1) in H3. + destruct (CRltLinear R1). + destruct (s _ x _ H3). + - exfalso. apply (CRmorph_increasing _ _ f) in c. + destruct (CRmorph_rat _ _ f r) as [H4 _]. + apply (CRle_lt_trans R2 _ _ _ H4) in c. clear H4. + exact (CRlt_asym R2 _ _ c H2). + - clear H2 H3 r. apply (CRlt_trans R1 _ _ _ c). clear c. + destruct (CR_Q_dense R2 _ _ H1) as [t [H2 H3]]. + apply lt_CR_of_Q, (CR_of_Q_lt R1) in H2. + destruct (s _ y _ H2). exact c. + exfalso. apply (CRmorph_increasing _ _ f) in c. + destruct (CRmorph_rat _ _ f t) as [_ H4]. + apply (CRlt_le_trans R2 _ _ _ c) in H4. clear c. + exact (CRlt_asym R2 _ _ H4 H3). +Qed. + +Lemma CRmorph_unique : forall (R1 R2 : ConstructiveReals) + (f g : ConstructiveRealsMorphism R1 R2) + (x : CRcarrier R1), + orderEq _ (CRlt R2) (CRmorph _ _ f x) (CRmorph _ _ g x). +Proof. + split. + - intro abs. destruct (CR_Q_dense R2 _ _ abs) as [q [H H0]]. + destruct (CRmorph_rat _ _ f q) as [H1 _]. + apply (CRlt_le_trans R2 _ _ _ H) in H1. clear H. + apply CRmorph_increasing_inv in H1. + destruct (CRmorph_rat _ _ g q) as [_ H2]. + apply (CRle_lt_trans R2 _ _ _ H2) in H0. clear H2. + apply CRmorph_increasing_inv in H0. + exact (CRlt_asym R1 _ _ H0 H1). + - intro abs. destruct (CR_Q_dense R2 _ _ abs) as [q [H H0]]. + destruct (CRmorph_rat _ _ f q) as [_ H1]. + apply (CRle_lt_trans R2 _ _ _ H1) in H0. clear H1. + apply CRmorph_increasing_inv in H0. + destruct (CRmorph_rat _ _ g q) as [H2 _]. + apply (CRlt_le_trans R2 _ _ _ H) in H2. clear H. + apply CRmorph_increasing_inv in H2. + exact (CRlt_asym R1 _ _ H0 H2). +Qed. + + +(* The identity is the only endomorphism of constructive reals. + For any ConstructiveReals R1, R2 and any morphisms + f : R1 -> R2 and g : R2 -> R1, + f and g are isomorphisms and are inverses of each other. *) +Lemma Endomorph_id : forall (R : ConstructiveReals) (f : ConstructiveRealsMorphism R R) + (x : CRcarrier R), + orderEq _ (CRlt R) (CRmorph _ _ f x) x. +Proof. + split. + - intro abs. destruct (CR_Q_dense R _ _ abs) as [q [H0 H1]]. + destruct (CRmorph_rat _ _ f q) as [H _]. + apply (CRlt_le_trans R _ _ _ H0) in H. clear H0. + apply CRmorph_increasing_inv in H. + exact (CRlt_asym R _ _ H1 H). + - intro abs. destruct (CR_Q_dense R _ _ abs) as [q [H0 H1]]. + destruct (CRmorph_rat _ _ f q) as [_ H]. + apply (CRle_lt_trans R _ _ _ H) in H1. clear H. + apply CRmorph_increasing_inv in H1. + exact (CRlt_asym R _ _ H1 H0). +Qed. + +Lemma CRmorph_proper : forall (R1 R2 : ConstructiveReals) + (f : ConstructiveRealsMorphism R1 R2) + (x y : CRcarrier R1), + orderEq _ (CRlt R1) x y + -> orderEq _ (CRlt R2) (CRmorph _ _ f x) (CRmorph _ _ f y). +Proof. + split. + - intro abs. apply CRmorph_increasing_inv in abs. + destruct H. contradiction. + - intro abs. apply CRmorph_increasing_inv in abs. + destruct H. contradiction. +Qed. + +Definition CRmorph_compose (R1 R2 R3 : ConstructiveReals) + (f : ConstructiveRealsMorphism R1 R2) + (g : ConstructiveRealsMorphism R2 R3) + : ConstructiveRealsMorphism R1 R3. +Proof. + apply (Build_ConstructiveRealsMorphism + R1 R3 (fun x:CRcarrier R1 => CRmorph _ _ g (CRmorph _ _ f x))). + - intro q. apply (CReq_trans R3 _ (CRmorph R2 R3 g (CR_of_Q R2 q))). + apply CRmorph_proper. apply CRmorph_rat. apply CRmorph_rat. + - intros. apply CRmorph_increasing. apply CRmorph_increasing. exact H. +Defined. + +Lemma CRmorph_le : forall (R1 R2 : ConstructiveReals) + (f : ConstructiveRealsMorphism R1 R2) + (x y : CRcarrier R1), + orderLe _ (CRlt R1) x y + -> orderLe _ (CRlt R2) (CRmorph _ _ f x) (CRmorph _ _ f y). +Proof. + intros. intro abs. apply CRmorph_increasing_inv in abs. contradiction. +Qed. + +Lemma CRmorph_le_inv : forall (R1 R2 : ConstructiveReals) + (f : ConstructiveRealsMorphism R1 R2) + (x y : CRcarrier R1), + orderLe _ (CRlt R2) (CRmorph _ _ f x) (CRmorph _ _ f y) + -> orderLe _ (CRlt R1) x y. +Proof. + intros. intro abs. apply (CRmorph_increasing _ _ f) in abs. contradiction. +Qed. + +Lemma CRmorph_zero : forall (R1 R2 : ConstructiveReals) + (f : ConstructiveRealsMorphism R1 R2), + orderEq _ (CRlt R2) (CRmorph _ _ f (CRzero R1)) (CRzero R2). +Proof. + intros. apply (CReq_trans R2 _ (CRmorph _ _ f (CR_of_Q R1 0))). + apply CRmorph_proper. apply CReq_sym, CR_of_Q_zero. + apply (CReq_trans R2 _ (CR_of_Q R2 0)). + apply CRmorph_rat. apply CR_of_Q_zero. +Qed. + +Lemma CRmorph_one : forall (R1 R2 : ConstructiveReals) + (f : ConstructiveRealsMorphism R1 R2), + orderEq _ (CRlt R2) (CRmorph _ _ f (CRone R1)) (CRone R2). +Proof. + intros. apply (CReq_trans R2 _ (CRmorph _ _ f (CR_of_Q R1 1))). + apply CRmorph_proper. apply CReq_sym, CR_of_Q_one. + apply (CReq_trans R2 _ (CR_of_Q R2 1)). + apply CRmorph_rat. apply CR_of_Q_one. +Qed. + +Lemma CRmorph_opp : forall (R1 R2 : ConstructiveReals) + (f : ConstructiveRealsMorphism R1 R2) + (x : CRcarrier R1), + orderEq _ (CRlt R2) (CRmorph _ _ f (CRopp R1 x)) + (CRopp R2 (CRmorph _ _ f x)). +Proof. + split. + - intro abs. + destruct (CR_Q_dense R2 _ _ abs) as [q [H H0]]. clear abs. + destruct (CRmorph_rat R1 R2 f q) as [H1 _]. + apply (CRlt_le_trans R2 _ _ _ H) in H1. clear H. + apply CRmorph_increasing_inv in H1. + apply CRopp_gt_lt_contravar in H0. + destruct (CR_of_Q_opp R2 q) as [H2 _]. + apply (CRlt_le_trans R2 _ _ _ H0) in H2. clear H0. + pose proof (CRopp_involutive R2 (CRmorph R1 R2 f x)) as [H _]. + apply (CRle_lt_trans R2 _ _ _ H) in H2. clear H. + destruct (CRmorph_rat R1 R2 f (-q)) as [H _]. + apply (CRlt_le_trans R2 _ _ _ H2) in H. clear H2. + apply CRmorph_increasing_inv in H. + destruct (CR_of_Q_opp R1 q) as [_ H2]. + apply (CRlt_le_trans R1 _ _ _ H) in H2. clear H. + apply CRopp_gt_lt_contravar in H2. + pose proof (CRopp_involutive R1 (CR_of_Q R1 q)) as [H _]. + apply (CRle_lt_trans R1 _ _ _ H) in H2. clear H. + exact (CRlt_asym R1 _ _ H1 H2). + - intro abs. + destruct (CR_Q_dense R2 _ _ abs) as [q [H H0]]. clear abs. + destruct (CRmorph_rat R1 R2 f q) as [_ H1]. + apply (CRle_lt_trans R2 _ _ _ H1) in H0. clear H1. + apply CRmorph_increasing_inv in H0. + apply CRopp_gt_lt_contravar in H. + pose proof (CRopp_involutive R2 (CRmorph R1 R2 f x)) as [_ H1]. + apply (CRlt_le_trans R2 _ _ _ H) in H1. clear H. + destruct (CR_of_Q_opp R2 q) as [_ H2]. + apply (CRle_lt_trans R2 _ _ _ H2) in H1. clear H2. + destruct (CRmorph_rat R1 R2 f (-q)) as [_ H]. + apply (CRle_lt_trans R2 _ _ _ H) in H1. clear H. + apply CRmorph_increasing_inv in H1. + destruct (CR_of_Q_opp R1 q) as [H2 _]. + apply (CRle_lt_trans R1 _ _ _ H2) in H1. clear H2. + apply CRopp_gt_lt_contravar in H1. + pose proof (CRopp_involutive R1 (CR_of_Q R1 q)) as [_ H]. + apply (CRlt_le_trans R1 _ _ _ H1) in H. clear H1. + exact (CRlt_asym R1 _ _ H0 H). +Qed. + +Lemma CRplus_pos_rat_lt : forall (R : ConstructiveReals) (x : CRcarrier R) (q : Q), + Qlt 0 q -> CRlt R x (CRplus R x (CR_of_Q R q)). +Proof. + intros. + apply (CRle_lt_trans R _ (CRplus R x (CRzero R))). apply CRplus_0_r. + apply CRplus_lt_compat_l. + apply (CRle_lt_trans R _ (CR_of_Q R 0)). apply CR_of_Q_zero. + apply CR_of_Q_lt. exact H. +Defined. + +Lemma CRplus_neg_rat_lt : forall (R : ConstructiveReals) (x : CRcarrier R) (q : Q), + Qlt q 0 -> CRlt R (CRplus R x (CR_of_Q R q)) x. +Proof. + intros. + apply (CRlt_le_trans R _ (CRplus R x (CRzero R))). 2: apply CRplus_0_r. + apply CRplus_lt_compat_l. + apply (CRlt_le_trans R _ (CR_of_Q R 0)). + apply CR_of_Q_lt. exact H. apply CR_of_Q_zero. +Qed. + +Lemma CRmorph_plus_rat : forall (R1 R2 : ConstructiveReals) + (f : ConstructiveRealsMorphism R1 R2) + (x : CRcarrier R1) (q : Q), + orderEq _ (CRlt R2) (CRmorph _ _ f (CRplus R1 x (CR_of_Q R1 q))) + (CRplus R2 (CRmorph _ _ f x) (CR_of_Q R2 q)). +Proof. + split. + - intro abs. + destruct (CR_Q_dense R2 _ _ abs) as [r [H H0]]. clear abs. + destruct (CRmorph_rat _ _ f r) as [H1 _]. + apply (CRlt_le_trans R2 _ _ _ H) in H1. clear H. + apply CRmorph_increasing_inv in H1. + apply (CRlt_asym R1 _ _ H1). clear H1. + apply (CRplus_lt_reg_r R1 (CRopp R1 (CR_of_Q R1 q))). + apply (CRlt_le_trans R1 _ x). + apply (CRle_lt_trans R1 _ (CR_of_Q R1 (r-q))). + apply (CRle_trans R1 _ (CRplus R1 (CR_of_Q R1 r) (CR_of_Q R1 (-q)))). + apply CRplus_le_compat_l. destruct (CR_of_Q_opp R1 q). exact H. + destruct (CR_of_Q_plus R1 r (-q)). exact H. + apply (CRmorph_increasing_inv _ _ f). + apply (CRle_lt_trans R2 _ (CR_of_Q R2 (r - q))). + apply CRmorph_rat. + apply (CRplus_lt_reg_r R2 (CR_of_Q R2 q)). + apply (CRle_lt_trans R2 _ (CR_of_Q R2 r)). 2: exact H0. + intro H. + destruct (CR_of_Q_plus R2 (r-q) q) as [H1 _]. + apply (CRlt_le_trans R2 _ _ _ H) in H1. clear H. + apply lt_CR_of_Q in H1. ring_simplify in H1. + exact (Qlt_not_le _ _ H1 (Qle_refl _)). + destruct (CRisRing R1). + apply (CRle_trans R1 _ (CRplus R1 x (CRplus R1 (CR_of_Q R1 q) (CRopp R1 (CR_of_Q R1 q))))). + apply (CRle_trans R1 _ (CRplus R1 x (CRzero R1))). + destruct (CRplus_0_r R1 x). exact H. + apply CRplus_le_compat_l. destruct (Ropp_def (CR_of_Q R1 q)). exact H. + destruct (Radd_assoc x (CR_of_Q R1 q) (CRopp R1 (CR_of_Q R1 q))). + exact H1. + - intro abs. + destruct (CR_Q_dense R2 _ _ abs) as [r [H H0]]. clear abs. + destruct (CRmorph_rat _ _ f r) as [_ H1]. + apply (CRle_lt_trans R2 _ _ _ H1) in H0. clear H1. + apply CRmorph_increasing_inv in H0. + apply (CRlt_asym R1 _ _ H0). clear H0. + apply (CRplus_lt_reg_r R1 (CRopp R1 (CR_of_Q R1 q))). + apply (CRle_lt_trans R1 _ x). + destruct (CRisRing R1). + apply (CRle_trans R1 _ (CRplus R1 x (CRplus R1 (CR_of_Q R1 q) (CRopp R1 (CR_of_Q R1 q))))). + destruct (Radd_assoc x (CR_of_Q R1 q) (CRopp R1 (CR_of_Q R1 q))). + exact H0. + apply (CRle_trans R1 _ (CRplus R1 x (CRzero R1))). + apply CRplus_le_compat_l. destruct (Ropp_def (CR_of_Q R1 q)). exact H1. + destruct (CRplus_0_r R1 x). exact H1. + apply (CRlt_le_trans R1 _ (CR_of_Q R1 (r-q))). + apply (CRmorph_increasing_inv _ _ f). + apply (CRlt_le_trans R2 _ (CR_of_Q R2 (r - q))). + apply (CRplus_lt_reg_r R2 (CR_of_Q R2 q)). + apply (CRlt_le_trans R2 _ _ _ H). + 2: apply CRmorph_rat. + apply (CRle_trans R2 _ (CR_of_Q R2 (r-q+q))). + intro abs. apply lt_CR_of_Q in abs. ring_simplify in abs. + exact (Qlt_not_le _ _ abs (Qle_refl _)). + destruct (CR_of_Q_plus R2 (r-q) q). exact H1. + apply (CRle_trans R1 _ (CRplus R1 (CR_of_Q R1 r) (CR_of_Q R1 (-q)))). + destruct (CR_of_Q_plus R1 r (-q)). exact H1. + apply CRplus_le_compat_l. destruct (CR_of_Q_opp R1 q). exact H1. +Qed. + +Lemma CRmorph_plus : forall (R1 R2 : ConstructiveReals) + (f : ConstructiveRealsMorphism R1 R2) + (x y : CRcarrier R1), + orderEq _ (CRlt R2) (CRmorph _ _ f (CRplus R1 x y)) + (CRplus R2 (CRmorph _ _ f x) (CRmorph _ _ f y)). +Proof. + intros R1 R2 f. + assert (forall (x y : CRcarrier R1), + orderLe _ (CRlt R2) (CRplus R2 (CRmorph R1 R2 f x) (CRmorph R1 R2 f y)) + (CRmorph R1 R2 f (CRplus R1 x y))). + { intros x y abs. destruct (CR_Q_dense R2 _ _ abs) as [r [H H0]]. clear abs. + destruct (CRmorph_rat _ _ f r) as [H1 _]. + apply (CRlt_le_trans R2 _ _ _ H) in H1. clear H. + apply CRmorph_increasing_inv in H1. + apply (CRlt_asym R1 _ _ H1). clear H1. + destruct (CR_Q_dense R2 _ _ H0) as [q [H2 H3]]. + apply lt_CR_of_Q in H2. + assert (Qlt (r-q) 0) as epsNeg. + { apply (Qplus_lt_r _ _ q). ring_simplify. exact H2. } + destruct (CR_Q_dense R1 _ _ (CRplus_neg_rat_lt R1 x (r-q) epsNeg)) + as [s [H4 H5]]. + apply (CRlt_trans R1 _ (CRplus R1 (CR_of_Q R1 s) y)). + 2: apply CRplus_lt_compat_r, H5. + apply (CRmorph_increasing_inv _ _ f). + apply (CRlt_le_trans R2 _ (CRplus R2 (CR_of_Q R2 s) (CRmorph _ _ f y))). + apply (CRmorph_increasing _ _ f) in H4. + destruct (CRmorph_plus_rat _ _ f x (r-q)) as [H _]. + apply (CRle_lt_trans R2 _ _ _ H) in H4. clear H. + destruct (CRmorph_rat _ _ f s) as [_ H1]. + apply (CRlt_le_trans R2 _ _ _ H4) in H1. clear H4. + apply (CRlt_trans R2 _ (CRplus R2 (CRplus R2 (CRmorph R1 R2 f x) (CR_of_Q R2 (r - q))) + (CRmorph R1 R2 f y))). + 2: apply CRplus_lt_compat_r, H1. + apply (CRlt_le_trans R2 _ (CRplus R2 (CRplus R2 (CR_of_Q R2 (r - q)) (CRmorph R1 R2 f x)) + (CRmorph R1 R2 f y))). + apply (CRlt_le_trans R2 _ (CRplus R2 (CR_of_Q R2 (r - q)) + (CRplus R2 (CRmorph R1 R2 f x) (CRmorph R1 R2 f y)))). + apply (CRle_lt_trans R2 _ (CRplus R2 (CR_of_Q R2 (r - q)) (CR_of_Q R2 q))). + 2: apply CRplus_lt_compat_l, H3. + intro abs. + destruct (CR_of_Q_plus R2 (r-q) q) as [_ H4]. + apply (CRle_lt_trans R2 _ _ _ H4) in abs. clear H4. + destruct (CRmorph_rat _ _ f r) as [_ H4]. + apply (CRlt_le_trans R2 _ _ _ abs) in H4. clear abs. + apply lt_CR_of_Q in H4. ring_simplify in H4. + exact (Qlt_not_le _ _ H4 (Qle_refl _)). + destruct (CRisRing R2); apply Radd_assoc. + apply CRplus_le_compat_r. destruct (CRisRing R2). + destruct (Radd_comm (CRmorph R1 R2 f x) (CR_of_Q R2 (r - q))). + exact H. + intro abs. + destruct (CRmorph_plus_rat _ _ f y s) as [H _]. apply H. clear H. + apply (CRlt_le_trans R2 _ (CRplus R2 (CR_of_Q R2 s) (CRmorph R1 R2 f y))). + apply (CRle_lt_trans R2 _ (CRmorph R1 R2 f (CRplus R1 (CR_of_Q R1 s) y))). + apply CRmorph_proper. destruct (CRisRing R1); apply Radd_comm. + exact abs. destruct (CRisRing R2); apply Radd_comm. } + split. + - apply H. + - specialize (H (CRplus R1 x y) (CRopp R1 y)). + intro abs. apply H. clear H. + apply (CRle_lt_trans R2 _ (CRmorph R1 R2 f x)). + apply CRmorph_proper. destruct (CRisRing R1). + apply (CReq_trans R1 _ (CRplus R1 x (CRplus R1 y (CRopp R1 y)))). + apply CReq_sym, Radd_assoc. + apply (CReq_trans R1 _ (CRplus R1 x (CRzero R1))). 2: apply CRplus_0_r. + destruct (CRisRingExt R1). apply Radd_ext. + apply CReq_refl. apply Ropp_def. + apply (CRplus_lt_reg_r R2 (CRmorph R1 R2 f y)). + apply (CRlt_le_trans R2 _ _ _ abs). clear abs. + apply (CRle_trans R2 _ (CRplus R2 (CRmorph R1 R2 f (CRplus R1 x y)) (CRzero R2))). + destruct (CRplus_0_r R2 (CRmorph R1 R2 f (CRplus R1 x y))). exact H. + apply (CRle_trans R2 _ (CRplus R2 (CRmorph R1 R2 f (CRplus R1 x y)) + (CRplus R2 (CRmorph R1 R2 f (CRopp R1 y)) (CRmorph R1 R2 f y)))). + apply CRplus_le_compat_l. + apply (CRle_trans R2 _ (CRplus R2 (CRopp R2 (CRmorph R1 R2 f y)) (CRmorph R1 R2 f y))). + destruct (CRplus_opp_l R2 (CRmorph R1 R2 f y)). exact H. + apply CRplus_le_compat_r. destruct (CRmorph_opp _ _ f y). exact H. + destruct (CRisRing R2). + destruct (Radd_assoc (CRmorph R1 R2 f (CRplus R1 x y)) + (CRmorph R1 R2 f (CRopp R1 y)) (CRmorph R1 R2 f y)). + exact H0. +Qed. + +Lemma CRmorph_mult_pos : forall (R1 R2 : ConstructiveReals) + (f : ConstructiveRealsMorphism R1 R2) + (x : CRcarrier R1) (n : nat), + orderEq _ (CRlt R2) (CRmorph _ _ f (CRmult R1 x (CR_of_Q R1 (Z.of_nat n # 1)))) + (CRmult R2 (CRmorph _ _ f x) (CR_of_Q R2 (Z.of_nat n # 1))). +Proof. + induction n. + - simpl. destruct (CRisRingExt R1). + apply (CReq_trans R2 _ (CRzero R2)). + + apply (CReq_trans R2 _ (CRmorph R1 R2 f (CRzero R1))). + 2: apply CRmorph_zero. apply CRmorph_proper. + apply (CReq_trans R1 _ (CRmult R1 x (CRzero R1))). + 2: apply CRmult_0_r. apply Rmul_ext. apply CReq_refl. apply CR_of_Q_zero. + + apply (CReq_trans R2 _ (CRmult R2 (CRmorph R1 R2 f x) (CRzero R2))). + apply CReq_sym, CRmult_0_r. destruct (CRisRingExt R2). + apply Rmul_ext0. apply CReq_refl. apply CReq_sym, CR_of_Q_zero. + - destruct (CRisRingExt R1), (CRisRingExt R2). + apply (CReq_trans + R2 _ (CRmorph R1 R2 f (CRplus R1 x (CRmult R1 x (CR_of_Q R1 (Z.of_nat n # 1)))))). + apply CRmorph_proper. + apply (CReq_trans R1 _ (CRmult R1 x (CRplus R1 (CRone R1) (CR_of_Q R1 (Z.of_nat n # 1))))). + apply Rmul_ext. apply CReq_refl. + apply (CReq_trans R1 _ (CR_of_Q R1 (1 + (Z.of_nat n # 1)))). + apply CR_of_Q_proper. rewrite Nat2Z.inj_succ. unfold Z.succ. + rewrite Z.add_comm. rewrite Qinv_plus_distr. reflexivity. + apply (CReq_trans R1 _ (CRplus R1 (CR_of_Q R1 1) (CR_of_Q R1 (Z.of_nat n # 1)))). + apply CR_of_Q_plus. apply Radd_ext. apply CR_of_Q_one. apply CReq_refl. + apply (CReq_trans R1 _ (CRplus R1 (CRmult R1 x (CRone R1)) + (CRmult R1 x (CR_of_Q R1 (Z.of_nat n # 1))))). + apply CRmult_plus_distr_l. apply Radd_ext. apply CRmult_1_r. apply CReq_refl. + apply (CReq_trans R2 _ (CRplus R2 (CRmorph R1 R2 f x) + (CRmorph R1 R2 f (CRmult R1 x (CR_of_Q R1 (Z.of_nat n # 1)))))). + apply CRmorph_plus. + apply (CReq_trans R2 _ (CRplus R2 (CRmorph R1 R2 f x) + (CRmult R2 (CRmorph R1 R2 f x) (CR_of_Q R2 (Z.of_nat n # 1))))). + apply Radd_ext0. apply CReq_refl. exact IHn. + apply (CReq_trans R2 _ (CRmult R2 (CRmorph R1 R2 f x) (CRplus R2 (CRone R2) (CR_of_Q R2 (Z.of_nat n # 1))))). + apply (CReq_trans R2 _ (CRplus R2 (CRmult R2 (CRmorph R1 R2 f x) (CRone R2)) + (CRmult R2 (CRmorph _ _ f x) (CR_of_Q R2 (Z.of_nat n # 1))))). + apply Radd_ext0. 2: apply CReq_refl. apply CReq_sym, CRmult_1_r. + apply CReq_sym, CRmult_plus_distr_l. + apply Rmul_ext0. apply CReq_refl. + apply (CReq_trans R2 _ (CR_of_Q R2 (1 + (Z.of_nat n # 1)))). + apply (CReq_trans R2 _ (CRplus R2 (CR_of_Q R2 1) (CR_of_Q R2 (Z.of_nat n # 1)))). + apply Radd_ext0. apply CReq_sym, CR_of_Q_one. apply CReq_refl. + apply CReq_sym, CR_of_Q_plus. + apply CR_of_Q_proper. rewrite Nat2Z.inj_succ. unfold Z.succ. + rewrite Z.add_comm. rewrite Qinv_plus_distr. reflexivity. +Qed. + +Lemma NatOfZ : forall n : Z, { p : nat | n = Z.of_nat p \/ n = Z.opp (Z.of_nat p) }. +Proof. + intros [|p|n]. + - exists O. left. reflexivity. + - exists (Pos.to_nat p). left. rewrite positive_nat_Z. reflexivity. + - exists (Pos.to_nat n). right. rewrite positive_nat_Z. reflexivity. +Qed. + +Lemma CRmorph_mult_int : forall (R1 R2 : ConstructiveReals) + (f : ConstructiveRealsMorphism R1 R2) + (x : CRcarrier R1) (n : Z), + orderEq _ (CRlt R2) (CRmorph _ _ f (CRmult R1 x (CR_of_Q R1 (n # 1)))) + (CRmult R2 (CRmorph _ _ f x) (CR_of_Q R2 (n # 1))). +Proof. + intros. destruct (NatOfZ n) as [p [pos|neg]]. + - subst n. apply CRmorph_mult_pos. + - subst n. + apply (CReq_trans R2 _ (CRopp R2 (CRmorph R1 R2 f (CRmult R1 x (CR_of_Q R1 (Z.of_nat p # 1)))))). + + apply (CReq_trans R2 _ (CRmorph R1 R2 f (CRopp R1 (CRmult R1 x (CR_of_Q R1 (Z.of_nat p # 1)))))). + 2: apply CRmorph_opp. apply CRmorph_proper. + apply (CReq_trans R1 _ (CRmult R1 x (CR_of_Q R1 (- (Z.of_nat p # 1))))). + destruct (CRisRingExt R1). apply Rmul_ext. apply CReq_refl. + apply CR_of_Q_proper. reflexivity. + apply (CReq_trans R1 _ (CRmult R1 x (CRopp R1 (CR_of_Q R1 (Z.of_nat p # 1))))). + destruct (CRisRingExt R1). apply Rmul_ext. apply CReq_refl. + apply CR_of_Q_opp. apply CReq_sym, CRopp_mult_distr_r. + + apply (CReq_trans R2 _ (CRopp R2 (CRmult R2 (CRmorph R1 R2 f x) (CR_of_Q R2 (Z.of_nat p # 1))))). + destruct (CRisRingExt R2). apply Ropp_ext. apply CRmorph_mult_pos. + apply (CReq_trans R2 _ (CRmult R2 (CRmorph R1 R2 f x) (CRopp R2 (CR_of_Q R2 (Z.of_nat p # 1))))). + apply CRopp_mult_distr_r. destruct (CRisRingExt R2). + apply Rmul_ext. apply CReq_refl. + apply (CReq_trans R2 _ (CR_of_Q R2 (- (Z.of_nat p # 1)))). + apply CReq_sym, CR_of_Q_opp. apply CR_of_Q_proper. reflexivity. +Qed. + +Lemma CRmorph_mult_inv : forall (R1 R2 : ConstructiveReals) + (f : ConstructiveRealsMorphism R1 R2) + (x : CRcarrier R1) (p : positive), + orderEq _ (CRlt R2) (CRmorph _ _ f (CRmult R1 x (CR_of_Q R1 (1 # p)))) + (CRmult R2 (CRmorph _ _ f x) (CR_of_Q R2 (1 # p))). +Proof. + intros. apply (CRmult_eq_reg_r R2 (CR_of_Q R2 (Z.pos p # 1))). + left. apply (CRle_lt_trans R2 _ (CR_of_Q R2 0)). + apply CR_of_Q_zero. apply CR_of_Q_lt. reflexivity. + apply (CReq_trans R2 _ (CRmorph _ _ f x)). + - apply (CReq_trans + R2 _ (CRmorph R1 R2 f (CRmult R1 (CRmult R1 x (CR_of_Q R1 (1 # p))) + (CR_of_Q R1 (Z.pos p # 1))))). + apply CReq_sym, CRmorph_mult_int. apply CRmorph_proper. + apply (CReq_trans + R1 _ (CRmult R1 x (CRmult R1 (CR_of_Q R1 (1 # p)) + (CR_of_Q R1 (Z.pos p # 1))))). + destruct (CRisRing R1). apply CReq_sym, Rmul_assoc. + apply (CReq_trans R1 _ (CRmult R1 x (CRone R1))). + apply (Rmul_ext (CRisRingExt R1)). apply CReq_refl. + apply (CReq_trans R1 _ (CR_of_Q R1 ((1#p) * (Z.pos p # 1)))). + apply CReq_sym, CR_of_Q_mult. + apply (CReq_trans R1 _ (CR_of_Q R1 1)). + apply CR_of_Q_proper. reflexivity. apply CR_of_Q_one. + apply CRmult_1_r. + - apply (CReq_trans R2 _ (CRmult R2 (CRmorph R1 R2 f x) + (CRmult R2 (CR_of_Q R2 (1 # p)) (CR_of_Q R2 (Z.pos p # 1))))). + 2: apply (Rmul_assoc (CRisRing R2)). + apply (CReq_trans R2 _ (CRmult R2 (CRmorph R1 R2 f x) (CRone R2))). + apply CReq_sym, CRmult_1_r. + apply (Rmul_ext (CRisRingExt R2)). apply CReq_refl. + apply (CReq_trans R2 _ (CR_of_Q R2 1)). + apply CReq_sym, CR_of_Q_one. + apply (CReq_trans R2 _ (CR_of_Q R2 ((1#p)*(Z.pos p # 1)))). + apply CR_of_Q_proper. reflexivity. apply CR_of_Q_mult. +Qed. + +Lemma CRmorph_mult_rat : forall (R1 R2 : ConstructiveReals) + (f : ConstructiveRealsMorphism R1 R2) + (x : CRcarrier R1) (q : Q), + orderEq _ (CRlt R2) (CRmorph _ _ f (CRmult R1 x (CR_of_Q R1 q))) + (CRmult R2 (CRmorph _ _ f x) (CR_of_Q R2 q)). +Proof. + intros. destruct q as [a b]. + apply (CReq_trans R2 _ (CRmult R2 (CRmorph _ _ f (CRmult R1 x (CR_of_Q R1 (a # 1)))) + (CR_of_Q R2 (1 # b)))). + - apply (CReq_trans + R2 _ (CRmorph R1 R2 f (CRmult R1 (CRmult R1 x (CR_of_Q R1 (a # 1))) + (CR_of_Q R1 (1 # b))))). + 2: apply CRmorph_mult_inv. apply CRmorph_proper. + apply (CReq_trans R1 _ (CRmult R1 x (CRmult R1 (CR_of_Q R1 (a # 1)) + (CR_of_Q R1 (1 # b))))). + apply (Rmul_ext (CRisRingExt R1)). apply CReq_refl. + apply (CReq_trans R1 _ (CR_of_Q R1 ((a#1)*(1#b)))). + apply CR_of_Q_proper. unfold Qeq; simpl. rewrite Z.mul_1_r. reflexivity. + apply CR_of_Q_mult. + apply (Rmul_assoc (CRisRing R1)). + - apply (CReq_trans R2 _ (CRmult R2 (CRmult R2 (CRmorph _ _ f x) (CR_of_Q R2 (a # 1))) + (CR_of_Q R2 (1 # b)))). + apply (Rmul_ext (CRisRingExt R2)). apply CRmorph_mult_int. + apply CReq_refl. + apply (CReq_trans R2 _ (CRmult R2 (CRmorph R1 R2 f x) + (CRmult R2 (CR_of_Q R2 (a # 1)) (CR_of_Q R2 (1 # b))))). + apply CReq_sym, (Rmul_assoc (CRisRing R2)). + apply (Rmul_ext (CRisRingExt R2)). apply CReq_refl. + apply (CReq_trans R2 _ (CR_of_Q R2 ((a#1)*(1#b)))). + apply CReq_sym, CR_of_Q_mult. + apply CR_of_Q_proper. unfold Qeq; simpl. rewrite Z.mul_1_r. reflexivity. +Qed. + +Lemma CRmorph_mult_pos_pos_le : forall (R1 R2 : ConstructiveReals) + (f : ConstructiveRealsMorphism R1 R2) + (x y : CRcarrier R1), + CRlt R1 (CRzero R1) y + -> orderLe _ (CRlt R2) (CRmult R2 (CRmorph _ _ f x) (CRmorph _ _ f y)) + (CRmorph _ _ f (CRmult R1 x y)). +Proof. + intros. intro abs. destruct (CR_Q_dense R2 _ _ abs) as [q [H1 H2]]. + destruct (CRmorph_rat _ _ f q) as [H3 _]. + apply (CRlt_le_trans R2 _ _ _ H1) in H3. clear H1. + apply CRmorph_increasing_inv in H3. + apply (CRlt_asym R1 _ _ H3). clear H3. + destruct (CR_Q_dense R2 _ _ H2) as [r [H1 H3]]. + apply lt_CR_of_Q in H1. + destruct (CR_archimedean R1 y) as [A Amaj]. + assert (/ ((r - q) * (1 # A)) * (q - r) == - (Z.pos A # 1)) as diveq. + { rewrite Qinv_mult_distr. setoid_replace (q-r) with (-1*(r-q)). + field_simplify. reflexivity. 2: field. + split. intro H4. inversion H4. intro H4. + apply Qlt_minus_iff in H1. rewrite H4 in H1. inversion H1. } + destruct (CR_Q_dense R1 (CRplus R1 x (CR_of_Q R1 ((q-r) * (1#A)))) x) + as [s [H4 H5]]. + - apply (CRlt_le_trans R1 _ (CRplus R1 x (CRzero R1))). + 2: apply CRplus_0_r. apply CRplus_lt_compat_l. + apply (CRplus_lt_reg_l R1 (CR_of_Q R1 ((r-q) * (1#A)))). + apply (CRle_lt_trans R1 _ (CRzero R1)). + apply (CRle_trans R1 _ (CR_of_Q R1 ((r-q)*(1#A) + (q-r)*(1#A)))). + destruct (CR_of_Q_plus R1 ((r-q)*(1#A)) ((q-r)*(1#A))). + exact H0. apply (CRle_trans R1 _ (CR_of_Q R1 0)). + 2: destruct (CR_of_Q_zero R1); exact H4. + intro H4. apply lt_CR_of_Q in H4. ring_simplify in H4. + inversion H4. + apply (CRlt_le_trans R1 _ (CR_of_Q R1 ((r - q) * (1 # A)))). + 2: apply CRplus_0_r. + apply (CRle_lt_trans R1 _ (CR_of_Q R1 0)). + apply CR_of_Q_zero. apply CR_of_Q_lt. + rewrite <- (Qmult_0_r (r-q)). apply Qmult_lt_l. + apply Qlt_minus_iff in H1. exact H1. reflexivity. + - apply (CRmorph_increasing _ _ f) in H4. + destruct (CRmorph_plus _ _ f x (CR_of_Q R1 ((q-r) * (1#A)))) as [H6 _]. + apply (CRle_lt_trans R2 _ _ _ H6) in H4. clear H6. + destruct (CRmorph_rat _ _ f s) as [_ H6]. + apply (CRlt_le_trans R2 _ _ _ H4) in H6. clear H4. + apply (CRmult_lt_compat_r R2 (CRmorph _ _ f y)) in H6. + destruct (Rdistr_l (CRisRing R2) (CRmorph _ _ f x) + (CRmorph R1 R2 f (CR_of_Q R1 ((q-r) * (1#A)))) + (CRmorph _ _ f y)) as [H4 _]. + apply (CRle_lt_trans R2 _ _ _ H4) in H6. clear H4. + apply (CRle_lt_trans R1 _ (CRmult R1 (CR_of_Q R1 s) y)). + 2: apply CRmult_lt_compat_r. 2: exact H. 2: exact H5. + apply (CRmorph_le_inv _ _ f). + apply (CRle_trans R2 _ (CR_of_Q R2 q)). + destruct (CRmorph_rat _ _ f q). exact H4. + apply (CRle_trans R2 _ (CRmult R2 (CR_of_Q R2 s) (CRmorph _ _ f y))). + apply (CRle_trans R2 _ (CRplus R2 (CRmult R2 (CRmorph _ _ f x) (CRmorph _ _ f y)) + (CR_of_Q R2 (q-r)))). + apply (CRle_trans R2 _ (CRplus R2 (CR_of_Q R2 r) (CR_of_Q R2 (q - r)))). + + apply (CRle_trans R2 _ (CR_of_Q R2 (r + (q-r)))). + intro H4. apply lt_CR_of_Q in H4. ring_simplify in H4. + exact (Qlt_not_le q q H4 (Qle_refl q)). + destruct (CR_of_Q_plus R2 r (q-r)). exact H4. + + apply CRplus_le_compat_r. intro H4. + apply (CRlt_asym R2 _ _ H3). exact H4. + + intro H4. apply (CRlt_asym R2 _ _ H4). clear H4. + apply (CRlt_trans_flip R2 _ _ _ H6). clear H6. + apply CRplus_lt_compat_l. + apply (CRlt_le_trans R2 _ (CRmult R2 (CR_of_Q R2 ((q - r) * (1 # A))) (CRmorph R1 R2 f y))). + apply (CRmult_lt_reg_l R2 (CR_of_Q R2 (/((r-q)*(1#A))))). + apply (CRle_lt_trans R2 _ (CR_of_Q R2 0)). apply CR_of_Q_zero. + apply CR_of_Q_lt, Qinv_lt_0_compat. + rewrite <- (Qmult_0_r (r-q)). apply Qmult_lt_l. + apply Qlt_minus_iff in H1. exact H1. reflexivity. + apply (CRle_lt_trans R2 _ (CRopp R2 (CR_of_Q R2 (Z.pos A # 1)))). + apply (CRle_trans R2 _ (CR_of_Q R2 (-(Z.pos A # 1)))). + apply (CRle_trans R2 _ (CR_of_Q R2 ((/ ((r - q) * (1 # A))) * (q - r)))). + destruct (CR_of_Q_mult R2 (/ ((r - q) * (1 # A))) (q - r)). + exact H0. destruct (CR_of_Q_proper R2 (/ ((r - q) * (1 # A)) * (q - r)) + (-(Z.pos A # 1))). + exact diveq. intro H7. apply lt_CR_of_Q in H7. + rewrite diveq in H7. exact (Qlt_not_le _ _ H7 (Qle_refl _)). + destruct (CR_of_Q_opp R2 (Z.pos A # 1)). exact H4. + apply (CRlt_le_trans R2 _ (CRopp R2 (CRmorph _ _ f y))). + apply CRopp_gt_lt_contravar. + apply (CRlt_le_trans R2 _ (CRmorph _ _ f (CR_of_Q R1 (Z.pos A # 1)))). + apply CRmorph_increasing. exact Amaj. + destruct (CRmorph_rat _ _ f (Z.pos A # 1)). exact H4. + apply (CRle_trans R2 _ (CRmult R2 (CRopp R2 (CRone R2)) (CRmorph _ _ f y))). + apply (CRle_trans R2 _ (CRopp R2 (CRmult R2 (CRone R2) (CRmorph R1 R2 f y)))). + destruct (Ropp_ext (CRisRingExt R2) (CRmorph _ _ f y) + (CRmult R2 (CRone R2) (CRmorph R1 R2 f y))). + apply CReq_sym, (Rmul_1_l (CRisRing R2)). exact H4. + destruct (CRopp_mult_distr_l R2 (CRone R2) (CRmorph _ _ f y)). exact H4. + apply (CRle_trans R2 _ (CRmult R2 (CRmult R2 (CR_of_Q R2 (/ ((r - q) * (1 # A)))) + (CR_of_Q R2 ((q - r) * (1 # A)))) + (CRmorph R1 R2 f y))). + apply CRmult_le_compat_r. + apply (CRle_lt_trans R2 _ (CRmorph _ _ f (CRzero R1))). + apply CRmorph_zero. apply CRmorph_increasing. exact H. + apply (CRle_trans R2 _ (CR_of_Q R2 ((/ ((r - q) * (1 # A))) + * ((q - r) * (1 # A))))). + apply (CRle_trans R2 _ (CR_of_Q R2 (-1))). + apply (CRle_trans R2 _ (CRopp R2 (CR_of_Q R2 1))). + destruct (Ropp_ext (CRisRingExt R2) (CRone R2) (CR_of_Q R2 1)). + apply CReq_sym, CR_of_Q_one. exact H4. + destruct (CR_of_Q_opp R2 1). exact H0. + destruct (CR_of_Q_proper R2 (-1) (/ ((r - q) * (1 # A)) * ((q - r) * (1 # A)))). + field. split. + intro H4. inversion H4. intro H4. apply Qlt_minus_iff in H1. + rewrite H4 in H1. inversion H1. exact H4. + destruct (CR_of_Q_mult R2 (/ ((r - q) * (1 # A))) ((q - r) * (1 # A))). + exact H4. + destruct (Rmul_assoc (CRisRing R2) (CR_of_Q R2 (/ ((r - q) * (1 # A)))) + (CR_of_Q R2 ((q - r) * (1 # A))) + (CRmorph R1 R2 f y)). + exact H0. + apply CRmult_le_compat_r. + apply (CRle_lt_trans R2 _ (CRmorph _ _ f (CRzero R1))). + apply CRmorph_zero. apply CRmorph_increasing. exact H. + destruct (CRmorph_rat _ _ f ((q - r) * (1 # A))). exact H0. + + apply (CRle_trans R2 _ (CRmorph _ _ f (CRmult R1 y (CR_of_Q R1 s)))). + apply (CRle_trans R2 _ (CRmult R2 (CRmorph R1 R2 f y) (CR_of_Q R2 s))). + destruct (Rmul_comm (CRisRing R2) (CRmorph R1 R2 f y) (CR_of_Q R2 s)). + exact H0. + destruct (CRmorph_mult_rat _ _ f y s). exact H0. + destruct (CRmorph_proper _ _ f (CRmult R1 y (CR_of_Q R1 s)) + (CRmult R1 (CR_of_Q R1 s) y)). + apply (Rmul_comm (CRisRing R1)). exact H4. + + apply (CRle_lt_trans R2 _ (CRmorph _ _ f (CRzero R1))). + apply CRmorph_zero. apply CRmorph_increasing. exact H. +Qed. + +Lemma CRmorph_mult_pos_pos : forall (R1 R2 : ConstructiveReals) + (f : ConstructiveRealsMorphism R1 R2) + (x y : CRcarrier R1), + CRlt R1 (CRzero R1) y + -> orderEq _ (CRlt R2) (CRmorph _ _ f (CRmult R1 x y)) + (CRmult R2 (CRmorph _ _ f x) (CRmorph _ _ f y)). +Proof. + split. apply CRmorph_mult_pos_pos_le. exact H. + intro abs. destruct (CR_Q_dense R2 _ _ abs) as [q [H1 H2]]. + destruct (CRmorph_rat _ _ f q) as [_ H3]. + apply (CRle_lt_trans R2 _ _ _ H3) in H2. clear H3. + apply CRmorph_increasing_inv in H2. + apply (CRlt_asym R1 _ _ H2). clear H2. + destruct (CR_Q_dense R2 _ _ H1) as [r [H2 H3]]. + apply lt_CR_of_Q in H3. + destruct (CR_archimedean R1 y) as [A Amaj]. + destruct (CR_Q_dense R1 x (CRplus R1 x (CR_of_Q R1 ((q-r) * (1#A))))) + as [s [H4 H5]]. + - apply (CRle_lt_trans R1 _ (CRplus R1 x (CRzero R1))). + apply CRplus_0_r. apply CRplus_lt_compat_l. + apply (CRle_lt_trans R1 _ (CR_of_Q R1 0)). + apply CR_of_Q_zero. apply CR_of_Q_lt. + rewrite <- (Qmult_0_r (q-r)). apply Qmult_lt_l. + apply Qlt_minus_iff in H3. exact H3. reflexivity. + - apply (CRmorph_increasing _ _ f) in H5. + destruct (CRmorph_plus _ _ f x (CR_of_Q R1 ((q-r) * (1#A)))) as [_ H6]. + apply (CRlt_le_trans R2 _ _ _ H5) in H6. clear H5. + destruct (CRmorph_rat _ _ f s) as [H5 _ ]. + apply (CRle_lt_trans R2 _ _ _ H5) in H6. clear H5. + apply (CRmult_lt_compat_r R2 (CRmorph _ _ f y)) in H6. + apply (CRlt_le_trans R1 _ (CRmult R1 (CR_of_Q R1 s) y)). + apply CRmult_lt_compat_r. exact H. exact H4. clear H4. + apply (CRmorph_le_inv _ _ f). + apply (CRle_trans R2 _ (CR_of_Q R2 q)). + 2: destruct (CRmorph_rat _ _ f q); exact H0. + apply (CRle_trans R2 _ (CRmult R2 (CR_of_Q R2 s) (CRmorph R1 R2 f y))). + + apply (CRle_trans R2 _ (CRmorph _ _ f (CRmult R1 y (CR_of_Q R1 s)))). + destruct (CRmorph_proper _ _ f (CRmult R1 (CR_of_Q R1 s) y) + (CRmult R1 y (CR_of_Q R1 s))). + apply (Rmul_comm (CRisRing R1)). exact H4. + apply (CRle_trans R2 _ (CRmult R2 (CRmorph R1 R2 f y) (CR_of_Q R2 s))). + exact (proj2 (CRmorph_mult_rat _ _ f y s)). + destruct (Rmul_comm (CRisRing R2) (CR_of_Q R2 s) (CRmorph R1 R2 f y)). + exact H0. + + intro H5. apply (CRlt_asym R2 _ _ H5). clear H5. + apply (CRlt_trans R2 _ _ _ H6). clear H6. + apply (CRle_lt_trans + R2 _ (CRplus R2 + (CRmult R2 (CRmorph _ _ f x) (CRmorph _ _ f y)) + (CRmult R2 (CRmorph R1 R2 f (CR_of_Q R1 ((q - r) * (1 # A)))) + (CRmorph R1 R2 f y)))). + apply (Rdistr_l (CRisRing R2)). + apply (CRle_lt_trans + R2 _ (CRplus R2 (CR_of_Q R2 r) + (CRmult R2 (CRmorph R1 R2 f (CR_of_Q R1 ((q - r) * (1 # A)))) + (CRmorph R1 R2 f y)))). + apply CRplus_le_compat_r. intro H5. apply (CRlt_asym R2 _ _ H5 H2). + clear H2. + apply (CRle_lt_trans + R2 _ (CRplus R2 (CR_of_Q R2 r) + (CRmult R2 (CR_of_Q R2 ((q - r) * (1 # A))) + (CRmorph R1 R2 f y)))). + apply CRplus_le_compat_l, CRmult_le_compat_r. + apply (CRle_lt_trans R2 _ (CRmorph _ _ f (CRzero R1))). + apply CRmorph_zero. apply CRmorph_increasing. exact H. + destruct (CRmorph_rat _ _ f ((q - r) * (1 # A))). exact H2. + apply (CRlt_le_trans R2 _ (CRplus R2 (CR_of_Q R2 r) + (CR_of_Q R2 ((q - r))))). + apply CRplus_lt_compat_l. + * apply (CRmult_lt_reg_l R2 (CR_of_Q R2 (/((q - r) * (1 # A))))). + apply (CRle_lt_trans R2 _ (CR_of_Q R2 0)). apply CR_of_Q_zero. + apply CR_of_Q_lt, Qinv_lt_0_compat. + rewrite <- (Qmult_0_r (q-r)). apply Qmult_lt_l. + apply Qlt_minus_iff in H3. exact H3. reflexivity. + apply (CRle_lt_trans R2 _ (CRmorph _ _ f y)). + apply (CRle_trans R2 _ (CRmult R2 (CRmult R2 (CR_of_Q R2 (/ ((q - r) * (1 # A)))) + (CR_of_Q R2 ((q - r) * (1 # A)))) + (CRmorph R1 R2 f y))). + exact (proj2 (Rmul_assoc (CRisRing R2) (CR_of_Q R2 (/ ((q - r) * (1 # A)))) + (CR_of_Q R2 ((q - r) * (1 # A))) + (CRmorph _ _ f y))). + apply (CRle_trans R2 _ (CRmult R2 (CRone R2) (CRmorph R1 R2 f y))). + apply CRmult_le_compat_r. + apply (CRle_lt_trans R2 _ (CRmorph _ _ f (CRzero R1))). + apply CRmorph_zero. apply CRmorph_increasing. exact H. + apply (CRle_trans R2 _ (CR_of_Q R2 ((/ ((q - r) * (1 # A))) * ((q - r) * (1 # A))))). + exact (proj1 (CR_of_Q_mult R2 (/ ((q - r) * (1 # A))) ((q - r) * (1 # A)))). + apply (CRle_trans R2 _ (CR_of_Q R2 1)). + destruct (CR_of_Q_proper R2 (/ ((q - r) * (1 # A)) * ((q - r) * (1 # A))) 1). + field_simplify. reflexivity. split. + intro H5. inversion H5. intro H5. apply Qlt_minus_iff in H3. + rewrite H5 in H3. inversion H3. exact H2. + destruct (CR_of_Q_one R2). exact H2. + destruct (Rmul_1_l (CRisRing R2) (CRmorph _ _ f y)). + intro H5. contradiction. + apply (CRlt_le_trans R2 _ (CR_of_Q R2 (Z.pos A # 1))). + apply (CRlt_le_trans R2 _ (CRmorph _ _ f (CR_of_Q R1 (Z.pos A # 1)))). + apply CRmorph_increasing. exact Amaj. + exact (proj2 (CRmorph_rat _ _ f (Z.pos A # 1))). + apply (CRle_trans R2 _ (CR_of_Q R2 ((/ ((q - r) * (1 # A))) * (q - r)))). + 2: exact (proj2 (CR_of_Q_mult R2 (/ ((q - r) * (1 # A))) (q - r))). + destruct (CR_of_Q_proper R2 (Z.pos A # 1) (/ ((q - r) * (1 # A)) * (q - r))). + field_simplify. reflexivity. split. + intro H5. inversion H5. intro H5. apply Qlt_minus_iff in H3. + rewrite H5 in H3. inversion H3. exact H2. + * apply (CRle_trans R2 _ (CR_of_Q R2 (r + (q-r)))). + exact (proj1 (CR_of_Q_plus R2 r (q-r))). + destruct (CR_of_Q_proper R2 (r + (q-r)) q). ring. exact H2. + + apply (CRle_lt_trans R2 _ (CRmorph _ _ f (CRzero R1))). + apply CRmorph_zero. apply CRmorph_increasing. exact H. +Qed. + +Lemma CRmorph_mult : forall (R1 R2 : ConstructiveReals) + (f : ConstructiveRealsMorphism R1 R2) + (x y : CRcarrier R1), + orderEq _ (CRlt R2) (CRmorph _ _ f (CRmult R1 x y)) + (CRmult R2 (CRmorph _ _ f x) (CRmorph _ _ f y)). +Proof. + intros. + destruct (CR_archimedean R1 (CRopp R1 y)) as [p pmaj]. + apply (CRplus_eq_reg_r R2 (CRmult R2 (CRmorph _ _ f x) + (CR_of_Q R2 (Z.pos p # 1)))). + apply (CReq_trans R2 _ (CRmorph _ _ f (CRmult R1 x (CRplus R1 y (CR_of_Q R1 (Z.pos p # 1)))))). + - apply (CReq_trans R2 _ (CRplus R2 (CRmorph R1 R2 f (CRmult R1 x y)) + (CRmorph R1 R2 f (CRmult R1 x (CR_of_Q R1 (Z.pos p # 1)))))). + apply (Radd_ext (CRisRingExt R2)). apply CReq_refl. + apply CReq_sym, CRmorph_mult_int. + apply (CReq_trans R2 _ (CRmorph _ _ f (CRplus R1 (CRmult R1 x y) + (CRmult R1 x (CR_of_Q R1 (Z.pos p # 1)))))). + apply CReq_sym, CRmorph_plus. apply CRmorph_proper. + apply CReq_sym, CRmult_plus_distr_l. + - apply (CReq_trans R2 _ (CRmult R2 (CRmorph _ _ f x) + (CRmorph _ _ f (CRplus R1 y (CR_of_Q R1 (Z.pos p # 1)))))). + apply CRmorph_mult_pos_pos. + apply (CRplus_lt_compat_l R1 y) in pmaj. + apply (CRle_lt_trans R1 _ (CRplus R1 y (CRopp R1 y))). + 2: exact pmaj. apply (CRisRing R1). + apply (CReq_trans R2 _ (CRmult R2 (CRmorph R1 R2 f x) + (CRplus R2 (CRmorph R1 R2 f y) (CR_of_Q R2 (Z.pos p # 1))))). + apply (Rmul_ext (CRisRingExt R2)). apply CReq_refl. + apply (CReq_trans R2 _ (CRplus R2 (CRmorph R1 R2 f y) + (CRmorph _ _ f (CR_of_Q R1 (Z.pos p # 1))))). + apply CRmorph_plus. + apply (Radd_ext (CRisRingExt R2)). apply CReq_refl. + apply CRmorph_rat. + apply CRmult_plus_distr_l. +Qed. + +Lemma CRmorph_appart : forall (R1 R2 : ConstructiveReals) + (f : ConstructiveRealsMorphism R1 R2) + (x y : CRcarrier R1) + (app : orderAppart _ (CRlt R1) x y), + orderAppart _ (CRlt R2) (CRmorph _ _ f x) (CRmorph _ _ f y). +Proof. + intros. destruct app. + - left. apply CRmorph_increasing. exact c. + - right. apply CRmorph_increasing. exact c. +Defined. + +Lemma CRmorph_appart_zero : forall (R1 R2 : ConstructiveReals) + (f : ConstructiveRealsMorphism R1 R2) + (x : CRcarrier R1) + (app : orderAppart _ (CRlt R1) x (CRzero R1)), + orderAppart _ (CRlt R2) (CRmorph _ _ f x) (CRzero R2). +Proof. + intros. destruct app. + - left. apply (CRlt_le_trans R2 _ (CRmorph _ _ f (CRzero R1))). + apply CRmorph_increasing. exact c. + exact (proj2 (CRmorph_zero _ _ f)). + - right. apply (CRle_lt_trans R2 _ (CRmorph _ _ f (CRzero R1))). + exact (proj1 (CRmorph_zero _ _ f)). + apply CRmorph_increasing. exact c. +Defined. + +Lemma CRmorph_inv : forall (R1 R2 : ConstructiveReals) + (f : ConstructiveRealsMorphism R1 R2) + (x : CRcarrier R1) + (xnz : orderAppart _ (CRlt R1) x (CRzero R1)) + (fxnz : orderAppart _ (CRlt R2) (CRmorph _ _ f x) (CRzero R2)), + orderEq _ (CRlt R2) (CRmorph _ _ f (CRinv R1 x xnz)) + (CRinv R2 (CRmorph _ _ f x) fxnz). +Proof. + intros. apply (CRmult_eq_reg_r R2 (CRmorph _ _ f x)). + destruct fxnz. right. exact c. left. exact c. + apply (CReq_trans R2 _ (CRone R2)). + 2: apply CReq_sym, CRinv_l. + apply (CReq_trans R2 _ (CRmorph _ _ f (CRmult R1 (CRinv R1 x xnz) x))). + apply CReq_sym, CRmorph_mult. + apply (CReq_trans R2 _ (CRmorph _ _ f (CRone R1))). + apply CRmorph_proper. apply CRinv_l. + apply CRmorph_one. +Qed. + +Definition CauchyMorph (R : ConstructiveReals) + : CReal -> CRcarrier R. +Proof. + intros [xn xcau]. + destruct (CR_complete R (fun n:nat => CR_of_Q R (xn n))). + - intros p. exists (Pos.to_nat p). intros. + specialize (xcau p i j H H0). apply Qlt_le_weak in xcau. + rewrite Qabs_Qle_condition in xcau. split. + + unfold CRminus. + apply (CRle_trans R _ (CRplus R (CR_of_Q R (xn i)) (CR_of_Q R (-xn j)))). + apply (CRle_trans R _ (CR_of_Q R (xn i-xn j))). + apply CR_of_Q_le. apply xcau. exact (proj2 (CR_of_Q_plus R _ _)). + apply CRplus_le_compat_l. exact (proj2 (CR_of_Q_opp R (xn j))). + + unfold CRminus. + apply (CRle_trans R _ (CRplus R (CR_of_Q R (xn i)) (CR_of_Q R (-xn j)))). + apply CRplus_le_compat_l. exact (proj1 (CR_of_Q_opp R (xn j))). + apply (CRle_trans R _ (CR_of_Q R (xn i-xn j))). + exact (proj1 (CR_of_Q_plus R _ _)). + apply CR_of_Q_le. apply xcau. + - exact x. +Defined. + +Lemma CauchyMorph_rat : forall (R : ConstructiveReals) (q : Q), + orderEq _ (CRlt R) (CauchyMorph R (inject_Q q)) (CR_of_Q R q). +Proof. + intros. + unfold CauchyMorph; simpl; + destruct (CRltLinear R), p, (CR_complete R (fun _ : nat => CR_of_Q R q)). + apply CR_cv_const in c0. apply CReq_sym. exact c0. +Qed. + +Lemma CauchyMorph_increasing_Ql : forall (R : ConstructiveReals) (x : CReal) (q : Q), + CRealLt x (inject_Q q) -> CRlt R (CauchyMorph R x) (CR_of_Q R q). +Proof. + intros. + unfold CauchyMorph; simpl; + destruct x as [xn xcau], (CRltLinear R), p, (CR_complete R (fun n : nat => CR_of_Q R (xn n))). + destruct (CRealQ_dense _ _ H) as [r [H0 H1]]. + apply lt_inject_Q in H1. + destruct (s _ x _ (CR_of_Q_lt R _ _ H1)). 2: exact c1. exfalso. + clear H1 H q. + (* For an index high enough, xn should be both higher + and lower than r, which is absurd. *) + apply CRealLt_above in H0. + destruct H0 as [p pmaj]. simpl in pmaj. + destruct (CR_cv_above_rat R xn x r c0 c1). + assert (x0 <= Nat.max (Pos.to_nat p) (S x0))%nat. + { apply (le_trans _ (S x0)). apply le_S, le_refl. apply Nat.le_max_r. } + specialize (q (Nat.max (Pos.to_nat p) (S x0)) H). clear H. + specialize (pmaj (Pos.max p (Pos.of_nat (S x0))) (Pos.le_max_l _ _)). + rewrite Pos2Nat.inj_max, Nat2Pos.id in pmaj. 2: discriminate. + apply (Qlt_not_le _ _ q). apply Qlt_le_weak. + apply Qlt_minus_iff. apply (Qlt_trans _ (2#p)). reflexivity. exact pmaj. +Qed. + +Lemma CauchyMorph_increasing_Qr : forall (R : ConstructiveReals) (x : CReal) (q : Q), + CRealLt (inject_Q q) x -> CRlt R (CR_of_Q R q) (CauchyMorph R x). +Proof. + intros. + unfold CauchyMorph; simpl; + destruct x as [xn xcau], (CRltLinear R), p, (CR_complete R (fun n : nat => CR_of_Q R (xn n))). + destruct (CRealQ_dense _ _ H) as [r [H0 H1]]. + apply lt_inject_Q in H0. + destruct (s _ x _ (CR_of_Q_lt R _ _ H0)). exact c1. exfalso. + clear H0 H q. + (* For an index high enough, xn should be both higher + and lower than r, which is absurd. *) + apply CRealLt_above in H1. + destruct H1 as [p pmaj]. simpl in pmaj. + destruct (CR_cv_below_rat R xn x r c0 c1). + assert (x0 <= Nat.max (Pos.to_nat p) (S x0))%nat. + { apply (le_trans _ (S x0)). apply le_S, le_refl. apply Nat.le_max_r. } + specialize (q (Nat.max (Pos.to_nat p) (S x0)) H). clear H. + specialize (pmaj (Pos.max p (Pos.of_nat (S x0))) (Pos.le_max_l _ _)). + rewrite Pos2Nat.inj_max, Nat2Pos.id in pmaj. 2: discriminate. + apply (Qlt_not_le _ _ q). apply Qlt_le_weak. + apply Qlt_minus_iff. apply (Qlt_trans _ (2#p)). reflexivity. exact pmaj. +Qed. + +Lemma CauchyMorph_increasing : forall (R : ConstructiveReals) (x y : CReal), + CRealLt x y -> CRlt R (CauchyMorph R x) (CauchyMorph R y). +Proof. + intros. + destruct (CRealQ_dense _ _ H) as [q [H0 H1]]. + apply (CRlt_trans R _ (CR_of_Q R q)). + apply CauchyMorph_increasing_Ql. exact H0. + apply CauchyMorph_increasing_Qr. exact H1. +Qed. + +Definition CauchyMorphism (R : ConstructiveReals) : ConstructiveRealsMorphism CRealImplem R. +Proof. + apply (Build_ConstructiveRealsMorphism CRealImplem R (CauchyMorph R)). + exact (CauchyMorph_rat R). + exact (CauchyMorph_increasing R). +Defined. + +Lemma RightBound : forall (R : ConstructiveReals) (x : CRcarrier R) (p q r : Q), + CRlt R x (CR_of_Q R q) + -> CRlt R x (CR_of_Q R r) + -> CRlt R (CR_of_Q R q) (CRplus R x (CR_of_Q R p)) + -> CRlt R (CR_of_Q R r) (CRplus R x (CR_of_Q R p)) + -> Qlt (Qabs (q - r)) p. +Proof. + intros. apply Qabs_case. + - intros. apply (Qplus_lt_l _ _ r). ring_simplify. + apply (lt_CR_of_Q R), (CRlt_le_trans R _ _ _ H1). + apply (CRle_trans R _ (CRplus R (CR_of_Q R r) (CR_of_Q R p))). + intro abs. apply CRplus_lt_reg_r in abs. + exact (CRlt_asym R _ _ abs H0). + destruct (CR_of_Q_plus R r p). exact H4. + - intros. apply (Qplus_lt_l _ _ q). ring_simplify. + apply (lt_CR_of_Q R), (CRlt_le_trans R _ _ _ H2). + apply (CRle_trans R _ (CRplus R (CR_of_Q R q) (CR_of_Q R p))). + intro abs. apply CRplus_lt_reg_r in abs. + exact (CRlt_asym R _ _ abs H). + destruct (CR_of_Q_plus R q p). exact H4. +Qed. + +Definition CauchyMorph_inv (R : ConstructiveReals) + : CRcarrier R -> CReal. +Proof. + intro x. + exists (fun n:nat => let (q,_) := CR_Q_dense + R x _ (CRplus_pos_rat_lt R x (1 # Pos.of_nat (S n)) (eq_refl _)) + in q). + intros n p q H0 H1. + destruct (CR_Q_dense R x (CRplus R x (CR_of_Q R (1 # Pos.of_nat (S p)))) + (CRplus_pos_rat_lt R x (1 # Pos.of_nat (S p)) (eq_refl _))) + as [r [H2 H3]]. + destruct (CR_Q_dense R x (CRplus R x (CR_of_Q R (1 # Pos.of_nat (S q)))) + (CRplus_pos_rat_lt R x (1 # Pos.of_nat (S q)) (eq_refl _))) + as [s [H4 H5]]. + apply (RightBound R x (1#n) r s). exact H2. exact H4. + apply (CRlt_trans R _ _ _ H3), CRplus_lt_compat_l, CR_of_Q_lt. + unfold Qlt. do 2 rewrite Z.mul_1_l. unfold Qden. + apply Pos2Z.pos_lt_pos, Pos2Nat.inj_lt. rewrite Nat2Pos.id. + 2: discriminate. apply le_n_S. exact H0. + apply (CRlt_trans R _ _ _ H5), CRplus_lt_compat_l, CR_of_Q_lt. + unfold Qlt. do 2 rewrite Z.mul_1_l. unfold Qden. + apply Pos2Z.pos_lt_pos, Pos2Nat.inj_lt. rewrite Nat2Pos.id. + 2: discriminate. apply le_n_S. exact H1. +Defined. + +Lemma CauchyMorph_inv_rat : forall (R : ConstructiveReals) (q : Q), + CRealEq (CauchyMorph_inv R (CR_of_Q R q)) (inject_Q q). +Proof. + split. + - intros [n nmaj]. unfold CauchyMorph_inv, proj1_sig, inject_Q in nmaj. + destruct (CR_Q_dense R (CR_of_Q R q) + (CRplus R (CR_of_Q R q) (CR_of_Q R (1 # Pos.of_nat (S (Pos.to_nat n))))) + (CRplus_pos_rat_lt R (CR_of_Q R q) (1 # Pos.of_nat (S (Pos.to_nat n))) + eq_refl)) + as [r [H _]]. + apply lt_CR_of_Q, Qlt_minus_iff in H. + apply (Qlt_not_le _ _ H), (Qplus_le_l _ _ (q-r)). + ring_simplify. apply (Qle_trans _ (2#n)). discriminate. + apply Qlt_le_weak. ring_simplify in nmaj. rewrite Qplus_comm. exact nmaj. + - intros [n nmaj]. unfold CauchyMorph_inv, proj1_sig, inject_Q in nmaj. + destruct (CR_Q_dense R (CR_of_Q R q) + (CRplus R (CR_of_Q R q) (CR_of_Q R (1 # Pos.of_nat (S (Pos.to_nat n))))) + (CRplus_pos_rat_lt R (CR_of_Q R q) (1 # Pos.of_nat (S (Pos.to_nat n))) + eq_refl)) + as [r [_ H0]]. + destruct (CR_of_Q_plus R q (1 # Pos.of_nat (S (Pos.to_nat n)))) as [H1 _]. + apply (CRlt_le_trans R _ _ _ H0) in H1. clear H0. + apply lt_CR_of_Q, (Qplus_lt_l _ _ (-q)) in H1. + ring_simplify in H1. ring_simplify in nmaj. + apply (Qlt_trans _ _ _ nmaj) in H1. clear nmaj. + apply (Qlt_not_le _ _ H1). clear H1. + apply (Qle_trans _ (1#n)). + unfold Qle, Qnum, Qden. do 2 rewrite Z.mul_1_l. + apply Pos2Z.pos_le_pos. apply Pos2Nat.inj_le. + rewrite Nat2Pos.id. 2: discriminate. apply le_S, le_refl. + unfold Qle, Qnum, Qden. apply Z.mul_le_mono_nonneg_r. + 2: discriminate. apply Pos2Z.pos_is_nonneg. +Qed. + +(* The easier side, because CauchyMorph_inv takes a limit from above. *) +Lemma CauchyMorph_inv_increasing_Qr + : forall (R : ConstructiveReals) (x : CRcarrier R) (q : Q), + CRlt R (CR_of_Q R q) x -> CRealLt (inject_Q q) (CauchyMorph_inv R x). +Proof. + intros. + destruct (CR_Q_dense R _ _ H) as [r [H2 H3]]. + apply lt_CR_of_Q in H2. + destruct (Qarchimedean (/(r-q))) as [p pmaj]. + exists (2*p)%positive. unfold CauchyMorph_inv, inject_Q, proj1_sig. + destruct (CR_Q_dense + R x (CRplus R x (CR_of_Q R (1 # Pos.of_nat (S (Pos.to_nat (2*p)))))) + (CRplus_pos_rat_lt R x (1 # Pos.of_nat (S (Pos.to_nat (2*p)))) eq_refl)) + as [t [H4 H5]]. + setoid_replace (2#2*p) with (1#p). 2: reflexivity. + apply (Qlt_trans _ (r-q)). + apply (Qmult_lt_l _ _ (r-q)) in pmaj. + rewrite Qmult_inv_r in pmaj. + apply Qlt_shift_inv_r in pmaj. 2: reflexivity. exact pmaj. + intro abs. apply Qlt_minus_iff in H2. + rewrite abs in H2. inversion H2. + apply Qlt_minus_iff in H2. exact H2. + apply Qplus_lt_l, (lt_CR_of_Q R), (CRlt_trans R _ x _ H3 H4). +Qed. + +Lemma CauchyMorph_inv_increasing : forall (R : ConstructiveReals) (x y : CRcarrier R), + CRlt R x y -> CRealLt (CauchyMorph_inv R x) (CauchyMorph_inv R y). +Proof. + intros. + destruct (CR_Q_dense R _ _ H) as [q [H0 H1]]. + apply (CReal_lt_trans _ (inject_Q q)). + - clear H1 H y. + destruct (CR_Q_dense R _ _ H0) as [r [H2 H3]]. + apply lt_CR_of_Q in H3. + destruct (Qarchimedean (/(q-r))) as [p pmaj]. + exists (4*p)%positive. unfold CauchyMorph_inv, inject_Q, proj1_sig. + destruct (CR_Q_dense + R x (CRplus R x (CR_of_Q R (1 # Pos.of_nat (S (Pos.to_nat (4*p)))))) + (CRplus_pos_rat_lt R x (1 # Pos.of_nat (S (Pos.to_nat (4*p)))) eq_refl)) + as [t [H4 H5]]. + setoid_replace (2#4*p) with (1#2*p). 2: reflexivity. + assert (1 # 2 * p < (q - r) / 2) as H. + { apply Qlt_shift_div_l. reflexivity. + setoid_replace ((1#2*p)*2) with (1#p). + apply (Qmult_lt_l _ _ (q-r)) in pmaj. + rewrite Qmult_inv_r in pmaj. + apply Qlt_shift_inv_r in pmaj. 2: reflexivity. exact pmaj. + intro abs. apply Qlt_minus_iff in H3. + rewrite abs in H3. inversion H3. + apply Qlt_minus_iff in H3. exact H3. + rewrite Qmult_comm. reflexivity. } + apply (Qlt_trans _ ((q-r)/2)). exact H. + apply (Qplus_lt_l _ _ (t + (r-q)/2)). field_simplify. + setoid_replace (2*t/2) with t. 2: field. + apply (lt_CR_of_Q R). apply (CRlt_trans R _ _ _ H5). + apply (CRlt_trans + R _ (CRplus R (CR_of_Q R r) (CR_of_Q R (1 # Pos.of_nat (S (Pos.to_nat (4 * p))))))). + apply CRplus_lt_compat_r. exact H2. + apply (CRle_lt_trans + R _ (CR_of_Q R (r + (1 # Pos.of_nat (S (Pos.to_nat (4 * p))))))). + apply CR_of_Q_plus. apply CR_of_Q_lt. + apply (Qlt_le_trans _ (r + (q-r)/2)). + 2: field_simplify; apply Qle_refl. + apply Qplus_lt_r. + apply (Qlt_trans _ (1#2*p)). 2: exact H. + unfold Qlt. do 2 rewrite Z.mul_1_l. unfold Qden. + apply Pos2Z.pos_lt_pos. + rewrite Nat2Pos.inj_succ, Pos2Nat.id. + apply (Pos.lt_trans _ (4*p)). apply Pos2Nat.inj_lt. + do 2 rewrite Pos2Nat.inj_mul. + apply Nat.mul_lt_mono_pos_r. apply Pos2Nat.is_pos. + unfold Pos.to_nat. simpl. auto. + apply Pos.lt_succ_diag_r. + intro abs. pose proof (Pos2Nat.is_pos (4*p)). + rewrite abs in H1. inversion H1. + - apply CauchyMorph_inv_increasing_Qr. exact H1. +Qed. + +Definition CauchyMorphismInv (R : ConstructiveReals) + : ConstructiveRealsMorphism R CRealImplem. +Proof. + apply (Build_ConstructiveRealsMorphism R CRealImplem (CauchyMorph_inv R)). + - apply CauchyMorph_inv_rat. + - apply CauchyMorph_inv_increasing. +Defined. + +Lemma CauchyMorph_surject : forall (R : ConstructiveReals) (x : CRcarrier R), + orderEq _ (CRlt R) (CauchyMorph R (CauchyMorph_inv R x)) x. +Proof. + intros. + apply (Endomorph_id + R (CRmorph_compose _ _ _ (CauchyMorphismInv R) (CauchyMorphism R)) x). +Qed. + +Lemma CauchyMorph_inject : forall (R : ConstructiveReals) (x : CReal), + CRealEq (CauchyMorph_inv R (CauchyMorph R x)) x. +Proof. + intros. + apply (Endomorph_id CRealImplem (CRmorph_compose _ _ _ (CauchyMorphism R) (CauchyMorphismInv R)) x). +Qed. + +(* We call this morphism slow to remind that it should only be used + for proofs, not for computations. *) +Definition SlowConstructiveRealsMorphism (R1 R2 : ConstructiveReals) + : ConstructiveRealsMorphism R1 R2 + := CRmorph_compose R1 CRealImplem R2 + (CauchyMorphismInv R1) (CauchyMorphism R2). diff --git a/theories/Reals/Raxioms.v b/theories/Reals/Raxioms.v index f03b0ccea3..d856d1c7fe 100644 --- a/theories/Reals/Raxioms.v +++ b/theories/Reals/Raxioms.v @@ -21,6 +21,7 @@ Require Export ZArith_base. Require Import ConstructiveRIneq. +Require Import ConstructiveRealsLUB. Require Export Rdefinitions. Declare Scope R_scope. Local Open Scope R_scope. @@ -408,6 +409,10 @@ Lemma completeness : bound E -> (exists x : R, E x) -> { m:R | is_lub E m }. Proof. intros. pose (fun x:ConstructiveRIneq.R => E (Rabst x)) as Er. + assert (forall x y : CRcarrier CR, orderEq (CRcarrier CR) (CRlt CR) x y -> Er x <-> Er y) + as Erproper. + { intros. unfold Er. replace (Rabst x) with (Rabst y). reflexivity. + apply Rquot1. do 2 rewrite Rquot2. split; apply H1. } assert (exists x : ConstructiveRIneq.R, Er x) as Einhab. { destruct H0. exists (Rrepr x). unfold Er. replace (Rabst (Rrepr x)) with x. exact H0. @@ -418,7 +423,7 @@ Proof. { destruct H. exists (Rrepr x). intros y Ey. rewrite <- (Rquot2 y). apply Rrepr_le. apply H. exact Ey. } destruct (CR_sig_lub CR - Er sig_forall_dec sig_not_dec Einhab Ebound). + Er Erproper sig_forall_dec sig_not_dec Einhab Ebound). exists (Rabst x). split. intros y Ey. apply Rrepr_le. rewrite Rquot2. unfold ConstructiveRIneq.Rle. apply a. diff --git a/user-contrib/Ltac2/Constr.v b/user-contrib/Ltac2/Constr.v index 34299f3cf9..1e330b06d7 100644 --- a/user-contrib/Ltac2/Constr.v +++ b/user-contrib/Ltac2/Constr.v @@ -16,6 +16,10 @@ Ltac2 @ external type : constr -> constr := "ltac2" "constr_type". Ltac2 @ external equal : constr -> constr -> bool := "ltac2" "constr_equal". (** Strict syntactic equality: only up to α-conversion and evar expansion *) +Ltac2 Type relevance := [ Relevant | Irrelevant ]. + +Ltac2 Type 'a binder_annot := { binder_name : 'a; binder_relevance : relevance }. + Module Unsafe. (** Low-level access to kernel terms. Use with care! *) @@ -29,16 +33,16 @@ Ltac2 Type kind := [ | Evar (evar, constr array) | Sort (sort) | Cast (constr, cast, constr) -| Prod (ident option, constr, constr) -| Lambda (ident option, constr, constr) -| LetIn (ident option, constr, constr, constr) +| Prod (ident option binder_annot, constr, constr) +| Lambda (ident option binder_annot, constr, constr) +| LetIn (ident option binder_annot, constr, constr, constr) | App (constr, constr array) | Constant (constant, instance) | Ind (inductive, instance) | Constructor (constructor, instance) | Case (case, constr, constr, constr array) -| Fix (int array, int, ident option array, constr array, constr array) -| CoFix (int, ident option array, constr array, constr array) +| Fix (int array, int, ident option binder_annot array, constr array, constr array) +| CoFix (int, ident option binder_annot array, constr array, constr array) | Proj (projection, constr) | Uint63 (uint63) ]. diff --git a/vernac/classes.ml b/vernac/classes.ml index d5f5656e1d..0a8c4e6b0f 100644 --- a/vernac/classes.ml +++ b/vernac/classes.ml @@ -371,10 +371,9 @@ let declare_instance_open sigma ?hook ~tac ~global ~poly id pri imps udecl ids t the refinement manually.*) let gls = List.rev (Evd.future_goals sigma) in let sigma = Evd.reset_future_goals sigma in - let scope = DeclareDef.Global Declare.ImportDefaultBehavior in let kind = Decls.(IsDefinition Instance) in let hook = DeclareDef.Hook.(make (fun { S.dref ; _ } -> instance_hook pri global imps ?hook dref)) in - let info = Lemmas.Info.make ~hook ~scope ~kind () in + let info = Lemmas.Info.make ~hook ~kind () in let lemma = Lemmas.start_lemma ~name:id ~poly ~udecl ~info sigma (EConstr.of_constr termtype) in (* spiwack: I don't know what to do with the status here. *) let lemma = diff --git a/vernac/comProgramFixpoint.ml b/vernac/comProgramFixpoint.ml index 3497e6369f..0e17f2b274 100644 --- a/vernac/comProgramFixpoint.ml +++ b/vernac/comProgramFixpoint.ml @@ -44,41 +44,68 @@ let mkSubset sigma name typ prop = let make_qref s = qualid_of_string s let lt_ref = make_qref "Init.Peano.lt" +type family = SPropF | PropF | TypeF +let family_of_sort_family = let open Sorts in function + | InSProp -> SPropF + | InProp -> PropF + | InSet | InType -> TypeF + +let get_sigmatypes sigma ~sort ~predsort = + let open EConstr in + let which, sigsort = match predsort, sort with + | SPropF, _ | _, SPropF -> + user_err Pp.(str "SProp arguments not supported by Program Fixpoint yet.") + | PropF, PropF -> "ex", PropF + | PropF, TypeF -> "sig", TypeF + | TypeF, (PropF|TypeF) -> "sigT", TypeF + in + let sigma, ty = Evarutil.new_global sigma (lib_ref ("core."^which^".type")) in + let uinstance = snd (destRef sigma ty) in + let intro = mkRef (lib_ref ("core."^which^".intro"), uinstance) in + let p1 = mkRef (lib_ref ("core."^which^".proj1"), uinstance) in + let p2 = mkRef (lib_ref ("core."^which^".proj2"), uinstance) in + sigma, ty, intro, p1, p2, sigsort + let rec telescope sigma l = let open EConstr in let open Vars in match l with | [] -> assert false - | [LocalAssum (n, t)] -> + | [LocalAssum (n, t), _] -> sigma, t, [LocalDef (n, mkRel 1, t)], mkRel 1 - | LocalAssum (n, t) :: tl -> - let sigma, ty, tys, (k, constr) = + | (LocalAssum (n, t), tsort) :: tl -> + let sigma, ty, _tysort, tys, (k, constr) = List.fold_left - (fun (sigma, ty, tys, (k, constr)) decl -> + (fun (sigma, ty, tysort, tys, (k, constr)) (decl,sort) -> let t = RelDecl.get_type decl in let pred = mkLambda (RelDecl.get_annot decl, t, ty) in - let sigma, ty = Evarutil.new_global sigma (lib_ref "core.sigT.type") in - let sigma, intro = Evarutil.new_global sigma (lib_ref "core.sigT.intro") in + let sigma, ty, intro, p1, p2, sigsort = get_sigmatypes sigma ~predsort:tysort ~sort in let sigty = mkApp (ty, [|t; pred|]) in let intro = mkApp (intro, [|lift k t; lift k pred; mkRel k; constr|]) in - (sigma, sigty, pred :: tys, (succ k, intro))) - (sigma, t, [], (2, mkRel 1)) tl + (sigma, sigty, sigsort, (pred, p1, p2) :: tys, (succ k, intro))) + (sigma, t, tsort, [], (2, mkRel 1)) tl in let sigma, last, subst = List.fold_right2 - (fun pred decl (sigma, prev, subst) -> + (fun (pred,p1,p2) (decl,_) (sigma, prev, subst) -> let t = RelDecl.get_type decl in - let sigma, p1 = Evarutil.new_global sigma (lib_ref "core.sigT.proj1") in - let sigma, p2 = Evarutil.new_global sigma (lib_ref "core.sigT.proj2") in let proj1 = applist (p1, [t; pred; prev]) in let proj2 = applist (p2, [t; pred; prev]) in (sigma, lift 1 proj2, LocalDef (get_annot decl, proj1, t) :: subst)) (List.rev tys) tl (sigma, mkRel 1, []) in sigma, ty, (LocalDef (n, last, t) :: subst), constr - | LocalDef (n, b, t) :: tl -> + | (LocalDef (n, b, t), _) :: tl -> let sigma, ty, subst, term = telescope sigma tl in sigma, ty, (LocalDef (n, b, t) :: subst), lift 1 term +let telescope env sigma l = + let l, _ = List.fold_right_map (fun d env -> + let s = Retyping.get_sort_family_of env sigma (RelDecl.get_type d) in + let env = EConstr.push_rel d env in + (d, family_of_sort_family s), env) l env + in + telescope sigma l + let nf_evar_context sigma ctx = List.map (map_constr (fun c -> Evarutil.nf_evar sigma c)) ctx @@ -94,7 +121,7 @@ let build_wellfounded (recname,pl,bl,arityc,body) poly r measure notation = let top_env = push_rel_context binders_rel env in let sigma, top_arity = interp_type_evars ~program_mode:true top_env sigma arityc in let full_arity = it_mkProd_or_LetIn top_arity binders_rel in - let sigma, argtyp, letbinders, make = telescope sigma binders_rel in + let sigma, argtyp, letbinders, make = telescope env sigma binders_rel in let argname = Id.of_string "recarg" in let arg = LocalAssum (make_annot (Name argname) Sorts.Relevant, argtyp) in let binders = letbinders @ [arg] in diff --git a/vernac/obligations.ml b/vernac/obligations.ml index da14b6e979..c8cede1f84 100644 --- a/vernac/obligations.ml +++ b/vernac/obligations.ml @@ -397,8 +397,8 @@ let deps_remaining obls deps = deps [] -let goal_kind = DeclareDef.(Global Declare.ImportNeedQualified, Decls.(IsDefinition Definition)) -let goal_proof_kind = DeclareDef.(Global Declare.ImportNeedQualified, Decls.(IsProof Lemma)) +let goal_kind = Decls.(IsDefinition Definition) +let goal_proof_kind = Decls.(IsProof Lemma) let kind_of_obligation o = match o with @@ -487,7 +487,8 @@ let rec solve_obligation prg num tac = ++ str (string_of_list ", " (fun x -> string_of_int (succ x)) remaining)); in let obl = subst_deps_obl obls obl in - let scope, kind = kind_of_obligation (snd obl.obl_status) in + let scope = DeclareDef.(Global Declare.ImportNeedQualified) in + let kind = kind_of_obligation (snd obl.obl_status) in let evd = Evd.from_ctx prg.prg_ctx in let evd = Evd.update_sigma_env evd (Global.env ()) in let auto n oblset tac = auto_solve_obligations n ~oblset tac in |