diff options
318 files changed, 5478 insertions, 16797 deletions
diff --git a/.gitignore b/.gitignore index e52091ee26..58e1d346cf 100644 --- a/.gitignore +++ b/.gitignore @@ -52,6 +52,7 @@ config/Info-*.plist dev/ocamldebug-coq dev/camlp4.dbg plugins/micromega/csdpcert +plugins/micromega/.micromega.ml.generated kernel/byterun/dllcoqrun.so coqdoc.sty .csdp.cache @@ -150,7 +151,6 @@ plugins/ssr/ssrvernac.ml kernel/byterun/coq_jumptbl.h kernel/copcodes.ml tools/tolink.ml -theories/Numbers/Natural/BigN/NMake_gen.v ide/index_urls.txt .lia.cache checker/names.ml diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index a6a27194af..e1feabd064 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -241,10 +241,7 @@ validate:32bit: COMPILER: "$COMPILER_32BIT" EXTRA_PACKAGES: "gcc-multilib" -ci-bedrock-src: - <<: *ci-template - -ci-bedrock-facade: +ci-bignums: <<: *ci-template ci-color: @@ -256,6 +253,14 @@ ci-color: ci-compcert: <<: *ci-template +ci-coq-dpdgraph: + <<: *ci-template + variables: + <<: *ci-template-vars + EXTRA_OPAM: "ocamlgraph" + EXTRA_PACKAGES: "autoconf" + allow_failure: true + ci-coquelicot: <<: *ci-template variables: diff --git a/.travis.yml b/.travis.yml index 5cae5fcd32..e7082a9eeb 100644 --- a/.travis.yml +++ b/.travis.yml @@ -37,8 +37,7 @@ env: - TEST_TARGET="test-suite" COMPILER="4.02.3+32bit" - TEST_TARGET="validate" TW="travis_wait" - TEST_TARGET="validate" COMPILER="4.02.3+32bit" TW="travis_wait" - - TEST_TARGET="ci-bedrock-src" - - TEST_TARGET="ci-bedrock-facade" + - TEST_TARGET="ci-bignums" - TEST_TARGET="ci-color" - TEST_TARGET="ci-compcert" - TEST_TARGET="ci-coq-dpdgraph" EXTRA_OPAM="ocamlgraph" @@ -65,6 +64,7 @@ matrix: allow_failures: - env: TEST_TARGET="ci-coq-dpdgraph" EXTRA_OPAM="ocamlgraph" - env: TEST_TARGET="ci-geocoq" + - env: TEST_TARGET="ci-fiat-parsers" include: # Full Coq test-suite with two compilers @@ -157,7 +157,7 @@ script: - set -e - echo 'Configuring Coq...' && echo -en 'travis_fold:start:coq.config\\r' -- ./configure -local -usecamlp5 -native-compiler ${NATIVE_COMP} ${EXTRA_CONF} +- ./configure -local -native-compiler ${NATIVE_COMP} ${EXTRA_CONF} - echo -en 'travis_fold:end:coq.config\\r' - echo 'Building Coq...' && echo -en 'travis_fold:start:coq.build\\r' diff --git a/API/API.ml b/API/API.ml index 2b7bbd561b..515b152e42 100644 --- a/API/API.ml +++ b/API/API.ml @@ -138,6 +138,7 @@ module Typeclasses = Typeclasses module Pretype_errors = Pretype_errors module Notation = Notation module Declarations = Declarations +module Univops = Univops module Declareops = Declareops module Globnames = Globnames module Environ = Environ diff --git a/API/API.mli b/API/API.mli index 20a637c1fa..2fd3f27927 100644 --- a/API/API.mli +++ b/API/API.mli @@ -72,6 +72,7 @@ sig val pr : (Level.t -> Pp.std_ppcmds) -> t -> Pp.std_ppcmds end type 'a puniverses = 'a * Instance.t + val out_punivs : 'a puniverses -> 'a module Constraint : module type of struct include Univ.Constraint end @@ -84,7 +85,11 @@ sig end type universe_context = UContext.t - [@@ocaml.deprecated "alias of API.Names.UContext.t"] + [@@ocaml.deprecated "alias of API.Univ.UContext.t"] + + type abstract_universe_context = Univ.AUContext.t + type cumulativity_info = Univ.CumulativityInfo.t + type abstract_cumulativity_info = Univ.ACumulativityInfo.t module LSet : module type of struct include Univ.LSet end module ContextSet : @@ -1034,7 +1039,16 @@ sig | Undef of inline | Def of Term.constr Mod_subst.substituted | OpaqueDef of Opaqueproof.opaque - type constant_type = Declarations.constant_type + type template_arity = Declarations.template_arity = { + template_param_levels : Univ.Level.t option list; + template_level : Univ.Universe.t; + } + + type ('a, 'b) declaration_arity = ('a, 'b) Declarations.declaration_arity = + | RegularArity of 'a + | TemplateArity of 'b + + type constant_type = (Prelude.types, Context.Rel.t * template_arity) declaration_arity type constant_universes = Declarations.constant_universes type projection_body = Declarations.projection_body = { proj_ind : Names.MutInd.t; @@ -1045,12 +1059,12 @@ sig proj_body : Term.constr; } type typing_flags = Declarations.typing_flags + type constant_body = Declarations.constant_body = { const_hyps : Context.Named.t; const_body : constant_def; const_type : constant_type; const_body_code : Cemitcodes.to_patch_substituted option; - const_polymorphic : bool; const_universes : constant_universes; const_proj : projection_body option; const_inline_code : bool; @@ -1083,6 +1097,12 @@ sig | MEident of Names.ModPath.t | MEapply of module_alg_expr * Names.ModPath.t | MEwith of module_alg_expr * with_declaration + + type abstract_inductive_universes = Declarations.abstract_inductive_universes = + | Monomorphic_ind of Univ.UContext.t + | Polymorphic_ind of Univ.abstract_universe_context + | Cumulative_ind of Univ.abstract_cumulativity_info + type mutual_inductive_body = Declarations.mutual_inductive_body = { mind_packets : one_inductive_body array; mind_record : Declarations.record_body option; @@ -1092,8 +1112,7 @@ sig mind_nparams : int; mind_nparams_rec : int; mind_params_ctxt : Context.Rel.t; - mind_polymorphic : bool; - mind_universes : Univ.UContext.t; + mind_universes : Declarations.abstract_inductive_universes; mind_private : bool option; mind_typing_flags : Declarations.typing_flags; } @@ -1122,6 +1141,11 @@ sig | SFBmodtype of module_type_body end +module Univops : sig + val universes_of_constr : Term.constr -> Univ.LSet.t + val restrict_universe_context : Univ.ContextSet.t -> Univ.LSet.t -> Univ.ContextSet.t +end + module Environ : sig type env = Prelude.env @@ -1131,6 +1155,11 @@ sig uj_val : 'constr; uj_type : 'types } + type 'types punsafe_type_judgment = 'types Environ.punsafe_type_judgment = { + utj_val : 'types; + utj_type : Sorts.t } + + type unsafe_type_judgment = Term.types punsafe_type_judgment val empty_env : env val lookup_mind : Names.MutInd.t -> env -> Declarations.mutual_inductive_body val push_rel : Context.Rel.Declaration.t -> env -> env @@ -1156,6 +1185,7 @@ sig val fold_named_context_reverse : ('a -> Context.Named.Declaration.t -> 'a) -> init:'a -> env -> 'a val evaluable_named : Names.Id.t -> Environ.env -> bool + val push_context_set : ?strict:bool -> Univ.ContextSet.t -> env -> env end module UGraph : @@ -1219,6 +1249,7 @@ end module Typeops : sig + val infer_type : Environ.env -> Term.types -> Environ.unsafe_type_judgment val type_of_constant_type : Environ.env -> Declarations.constant_type -> Term.types val type_of_constant_in : Environ.env -> Term.pconstant -> Term.types end @@ -1900,6 +1931,7 @@ end module Decl_kinds : sig type polymorphic = bool + type cumulative_inductive_flag = bool type recursivity_kind = Decl_kinds.recursivity_kind = | Finite | CoFinite @@ -2055,8 +2087,10 @@ sig type explicitation = Constrexpr.explicitation = | ExplByPos of int * Names.Id.t option | ExplByName of Names.Id.t + type sign = bool + type raw_natural_number = string type prim_token = Constrexpr.prim_token = - | Numeral of Bigint.bigint + | Numeral of raw_natural_number * sign | String of string type notation = string type instance_expr = Misctypes.glob_level list @@ -2379,7 +2413,7 @@ sig | VernacExactProof of Constrexpr.constr_expr | VernacAssumption of (Decl_kinds.locality option * Decl_kinds.assumption_object_kind) * inline * (plident list * Constrexpr.constr_expr) with_coercion list - | VernacInductive of Decl_kinds.private_flag * inductive_flag * (inductive_expr * decl_notation list) list + | VernacInductive of Decl_kinds.cumulative_inductive_flag * Decl_kinds.private_flag * inductive_flag * (inductive_expr * decl_notation list) list | VernacFixpoint of Decl_kinds.locality option * (fixpoint_expr * decl_notation list) list | VernacCoFixpoint of @@ -2556,6 +2590,20 @@ sig and closed_glob_constr = Glob_term.closed_glob_constr = { closure: closure; term: glob_constr } + + type var_map = Pattern.constr_under_binders Names.Id.Map.t + type uconstr_var_map = Glob_term.closed_glob_constr Names.Id.Map.t + type unbound_ltac_var_map = Geninterp.Val.t Names.Id.Map.t + type ltac_var_map = Glob_term.ltac_var_map = { + ltac_constrs : var_map; + (** Ltac variables bound to constrs *) + ltac_uconstrs : uconstr_var_map; + (** Ltac variables bound to untyped constrs *) + ltac_idents: Names.Id.t Names.Id.Map.t; + (** Ltac variables bound to identifiers *) + ltac_genargs : unbound_ltac_var_map; + (** Ltac variables bound to other kinds of arguments *) + } end module Libnames : @@ -2631,10 +2679,9 @@ sig type universe_opt_subst = Universes.universe_opt_subst val fresh_inductive_instance : Environ.env -> Names.inductive -> Term.pinductive Univ.in_universe_context_set val new_Type : Names.DirPath.t -> Term.types + val type_of_global : Globnames.global_reference -> Term.types Univ.in_universe_context_set val unsafe_type_of_global : Globnames.global_reference -> Term.types val constr_of_global : Prelude.global_reference -> Term.constr - val universes_of_constr : Term.constr -> Univ.LSet.t - val restrict_universe_context : Univ.ContextSet.t -> Univ.LSet.t -> Univ.ContextSet.t val new_univ_level : Names.DirPath.t -> Univ.Level.t val unsafe_constr_of_global : Globnames.global_reference -> Term.constr Univ.in_universe_context val new_sort_in_family : Sorts.family -> Sorts.t @@ -2680,7 +2727,6 @@ module Lib : sig | ClosedModule of library_segment | OpenedSection of Libnames.object_prefix * Summary.frozen | ClosedSection of library_segment - | FrozenState of Summary.frozen and library_segment = (Libnames.object_name * node) list @@ -2921,10 +2967,6 @@ sig | IsType | WithoutTypeConstraint - type var_map = Pattern.constr_under_binders Names.Id.Map.t - type uconstr_var_map = Glob_term.closed_glob_constr Names.Id.Map.t - type unbound_ltac_var_map = Geninterp.Val.t Names.Id.Map.t - type inference_hook = Environ.env -> Evd.evar_map -> Evar.t -> Evd.evar_map * EConstr.constr type inference_flags = Pretyping.inference_flags = { use_typeclasses : bool; @@ -2934,22 +2976,11 @@ sig expand_evars : bool } - type ltac_var_map = Pretyping.ltac_var_map = { - ltac_constrs : var_map; - (** Ltac variables bound to constrs *) - ltac_uconstrs : uconstr_var_map; - (** Ltac variables bound to untyped constrs *) - ltac_idents: Names.Id.t Names.Id.Map.t; - (** Ltac variables bound to identifiers *) - ltac_genargs : unbound_ltac_var_map; - (** Ltac variables bound to other kinds of arguments *) - } type pure_open_constr = Evd.evar_map * EConstr.constr - type glob_constr_ltac_closure = ltac_var_map * Glob_term.glob_constr + type glob_constr_ltac_closure = Glob_term.ltac_var_map * Glob_term.glob_constr - val empty_lvar : ltac_var_map val understand_ltac : inference_flags -> - Environ.env -> Evd.evar_map -> ltac_var_map -> + Environ.env -> Evd.evar_map -> Glob_term.ltac_var_map -> typing_constraint -> Glob_term.glob_constr -> pure_open_constr val understand_tcc : ?flags:inference_flags -> Environ.env -> Evd.evar_map -> ?expected_type:typing_constraint -> Glob_term.glob_constr -> Evd.evar_map * EConstr.constr @@ -2963,11 +2994,11 @@ sig val interp_elimination_sort : Misctypes.glob_sort -> Sorts.family val register_constr_interp0 : ('r, 'g, 't) Genarg.genarg_type -> - (unbound_ltac_var_map -> Environ.env -> Evd.evar_map -> EConstr.types -> 'g -> EConstr.constr * Evd.evar_map) -> unit + (Glob_term.unbound_ltac_var_map -> Environ.env -> Evd.evar_map -> EConstr.types -> 'g -> EConstr.constr * Evd.evar_map) -> unit val all_and_fail_flags : inference_flags val ise_pretype_gen : inference_flags -> Environ.env -> Evd.evar_map -> - ltac_var_map -> typing_constraint -> Glob_term.glob_constr -> Evd.evar_map * EConstr.constr + Glob_term.ltac_var_map -> typing_constraint -> Glob_term.glob_constr -> Evd.evar_map * EConstr.constr end module Evarconv : @@ -3307,6 +3338,7 @@ sig val declare_cache_obj : (unit -> unit) -> string -> unit val add_known_plugin : (unit -> unit) -> string -> unit val add_known_module : string -> unit + val module_is_known : string -> bool end (* All items in the Proof_type module are deprecated. *) @@ -3465,6 +3497,8 @@ sig (** @raise NoCurrentProof when outside proof mode. *) val discard_all : unit -> unit + val discard_current : unit -> unit + val get_current_proof_name : unit -> Names.Id.t end module Nametab : @@ -3473,6 +3507,7 @@ sig type ltac_constant = Names.KerName.t + val global : Libnames.reference -> Globnames.global_reference val global_of_path : Libnames.full_path -> Globnames.global_reference val shortest_qualid_of_global : Names.Id.Set.t -> Globnames.global_reference -> Libnames.qualid val path_of_global : Globnames.global_reference -> Libnames.full_path @@ -3795,6 +3830,7 @@ sig val cases_pattern_of_glob_constr : Names.Name.t -> Glob_term.glob_constr -> Glob_term.cases_pattern val map_glob_constr : (Glob_term.glob_constr -> Glob_term.glob_constr) -> Glob_term.glob_constr -> Glob_term.glob_constr + val empty_lvar : Glob_term.ltac_var_map end module Indrec : @@ -3939,11 +3975,18 @@ sig val solve : ?with_end_tac:unit Proofview.tactic -> Vernacexpr.goal_selector -> int option -> unit Proofview.tactic -> Proof.proof -> Proof.proof * bool - val delete_current_proof : unit -> unit val cook_proof : unit -> (Names.Id.t * (Safe_typing.private_constants Entries.definition_entry * Proof_global.proof_universes * Decl_kinds.goal_kind)) - val get_current_proof_name : unit -> Names.Id.t + val get_current_context : unit -> Evd.evar_map * Environ.env + + (* Deprecated *) + val delete_current_proof : unit -> unit + [@@ocaml.deprecated "use Proof_global.discard_current"] + + val get_current_proof_name : unit -> Names.Id.t + [@@ocaml.deprecated "use Proof_global.get_current_proof_name"] + end module Tactics : @@ -4100,7 +4143,7 @@ sig module New : sig - val refine : ?unsafe:bool -> (Evd.evar_map -> Evd.evar_map * EConstr.constr) -> unit Proofview.tactic + val refine : typecheck:bool -> (Evd.evar_map -> Evd.evar_map * EConstr.constr) -> unit Proofview.tactic val reduce_after_refine : unit Proofview.tactic end module Simple : @@ -4490,7 +4533,7 @@ end module Refine : sig - val refine : ?unsafe:bool -> (Evd.evar_map -> Evd.evar_map * EConstr.t) -> unit Proofview.tactic + val refine : typecheck:bool -> (Evd.evar_map -> Evd.evar_map * EConstr.t) -> unit Proofview.tactic val solve_constraints : unit Proofview.tactic end @@ -4727,7 +4770,9 @@ sig type one_inductive_impls = Command.one_inductive_impls val do_mutual_inductive : - (Vernacexpr.one_inductive_expr * Vernacexpr.decl_notation list) list -> Decl_kinds.polymorphic -> + (Vernacexpr.one_inductive_expr * Vernacexpr.decl_notation list) list -> + Decl_kinds.cumulative_inductive_flag -> + Decl_kinds.polymorphic -> Decl_kinds.private_flag -> Decl_kinds.recursivity_kind -> unit val do_definition : Names.Id.t -> Decl_kinds.definition_kind -> Vernacexpr.lident list option -> @@ -4751,7 +4796,9 @@ sig structured_inductive_expr * Libnames.qualid list * Vernacexpr.decl_notation list val interp_mutual_inductive : - structured_inductive_expr -> Vernacexpr.decl_notation list -> Decl_kinds.polymorphic -> + structured_inductive_expr -> Vernacexpr.decl_notation list -> + Decl_kinds.cumulative_inductive_flag -> + Decl_kinds.polymorphic -> Decl_kinds.private_flag -> Decl_kinds.recursivity_kind -> Entries.mutual_inductive_entry * Universes.universe_binders * one_inductive_impls list diff --git a/API/grammar_API.mli b/API/grammar_API.mli index 44aae771f6..c643f09086 100644 --- a/API/grammar_API.mli +++ b/API/grammar_API.mli @@ -116,7 +116,7 @@ sig val pattern_identref : Names.Id.t located Gram.Entry.e val base_ident : Names.Id.t Gram.Entry.e val natural : int Gram.Entry.e - val bigint : Bigint.bigint Gram.Entry.e + val bigint : Constrexpr.raw_natural_number Gram.Entry.e val integer : int Gram.Entry.e val string : string Gram.Entry.e val qualid : API.Libnames.qualid located Gram.Entry.e @@ -211,6 +211,7 @@ end module Mltop : sig val add_known_module : string -> unit + val module_is_known : string -> bool val declare_cache_obj : (unit -> unit) -> string -> unit end module Vernacinterp : @@ -50,6 +50,10 @@ Standard Library and, consequently, choice of representatives in equivalence classes. Various proof-theoretic characterizations of choice over setoids in file ChoiceFacts.v. +- The BigN, BigZ, BigZ libraries are not part anymore of Coq standard + library, they are now provided by a separate repository + https://github.com/coq/bignums + The split has been done just after the Int31 library. - IZR (Reals) has been changed to produce a compact representation of integers. As a consequence, IZR is no longer convertible to INR and @@ -90,6 +94,12 @@ Build Infrastructure access to the same .cmi files. In short, use "make -j && make -j byte" instead of "make -j world byte". +Universes + +- Cumulative inductive types. see prefixes "Cumulative", "NonCumulative" + for inductive definitions and the option "Set Inductive Cumulativity" + in the reference manual. + Changes from V8.6beta1 to V8.6 ============================== @@ -89,8 +89,7 @@ EXISTINGMLI := $(call find, '*.mli') GENML4FILES:= $(ML4FILES:.ml4=.ml) export GENMLFILES:=$(LEXFILES:.mll=.ml) tools/tolink.ml kernel/copcodes.ml export GENHFILES:=kernel/byterun/coq_jumptbl.h -export GENVFILES:=theories/Numbers/Natural/BigN/NMake_gen.v -export GENFILES:=$(GENMLFILES) $(GENMLIFILES) $(GENHFILES) $(GENVFILES) +export GENFILES:=$(GENMLFILES) $(GENMLIFILES) $(GENHFILES) # NB: all files in $(GENFILES) can be created initially, while # .ml files in $(GENML4FILES) might need some intermediate building. @@ -191,6 +190,7 @@ indepclean: rm -f test-suite/check.log rm -f glob.dump rm -f config/revision.ml revision + rm -f plugins/micromega/.micromega.ml.generated $(MAKE) -C test-suite clean docclean: diff --git a/Makefile.build b/Makefile.build index 6e048ce94d..0dafde9977 100644 --- a/Makefile.build +++ b/Makefile.build @@ -78,27 +78,6 @@ include Makefile.install include Makefile.dev ## provides the 'printers' and 'revision' rules ########################################################################### -# Adding missing pieces of information not discovered by ocamldep -# due to the fact that: -# - plugins/micromega/micromega_plugin.ml -# - plugins/micromega/micromega_plugin.mli -# are generated (and not yet present when we run "ocamldep"). -########################################################################### - -plugins/micromega/micromega_plugin.cmo : plugins/micromega/micromega.cmo -plugins/micromega/micromega_plugin.cmx : plugins/micromega/micromega.cmx - -plugins/micromega/certificate.cmo plugins/micromega/coq_micromega.cmo plugins/micromega/csdpcert.cmo plugins/micromega/mfourier.cmo plugins/micromega/mutils.cmo plugins/micromega/polynomial.cmo : plugins/micromega/micromega.cmo - -plugins/micromega/certificate.cmx plugins/micromega/coq_micromega.cmx plugins/micromega/csdpcert.cmx plugins/micromega/mfourier.cmx plugins/micromega/mutils.cmx plugins/micromega/polynomial.cmx : plugins/micromega/micromega.cmx - -plugins/micromega/micromega.cmx plugins/micromega/micromega.cmo : plugins/micromega/micromega.cmi -plugins/micromega/micromega.cmi : plugins/micromega/micromega.mli - -plugins/micromega/generated_micromega.mli plugins/micromega/generated_micromega.ml : plugins/micromega/MExtraction.vo - @: - -########################################################################### # This include below will lauch the build of all .d. # The - at front is for disabling warnings about currently missing ones. @@ -110,8 +89,6 @@ DEPENDENCIES := \ -include $(DEPENDENCIES) -plugins/micromega/micromega_FORPACK:= -for-pack Micromega_plugin - # All dependency includes must be declared secondary, otherwise make will # delete them if it decided to build them by dependency instead of because # of include, and they will then be automatically deleted, leading to an @@ -539,6 +516,27 @@ COND_OPTFLAGS= \ $(SHOW)'OCAMLC $<' $(HIDE)$(OCAMLC) $(COND_BYTEFLAGS) -c $< +## NB: for the moment ocamlopt erases and recreates .cmi if there's no .mli around. +## This can lead to nasty things with make -j. To avoid that: +## 1) We make .cmx always depend on .cmi +## 2) This .cmi will be created from the .mli, or trigger the compilation of the +## .cmo if there's no .mli (see rule below about MLWITHOUTMLI) +## 3) We tell ocamlopt to use the .cmi as the interface source file. With this +## hack, everything goes as if there is a .mli, and the .cmi is preserved +## and the .cmx is checked with respect to this .cmi + +HACKMLI = $(if $(wildcard $<i),,-intf-suffix .cmi) + +define diff + $(strip $(foreach f, $(1), $(if $(filter $(f),$(2)),,$f))) +endef + +MLWITHOUTMLI := $(call diff, $(MLFILES), $(MLIFILES:.mli=.ml)) + +$(MLWITHOUTMLI:.ml=.cmx): %.cmx: %.cmi # for .ml with .mli this is already the case + +$(MLWITHOUTMLI:.ml=.cmi): %.cmi: %.cmo + # NB: the *_FORPACK variables are generated in *.mlpack.d by ocamllibdep # The only exceptions are the sources of the csdpcert binary. # To avoid warnings, we set them manually here: @@ -549,11 +547,11 @@ plugins/micromega/csdpcert_FORPACK:= plugins/%.cmx: plugins/%.ml $(SHOW)'OCAMLOPT $<' - $(HIDE)$(OCAMLOPT) $(COND_OPTFLAGS) $($(@:.cmx=_FORPACK)) -c $< + $(HIDE)$(OCAMLOPT) $(COND_OPTFLAGS) $(HACKMLI) $($(@:.cmx=_FORPACK)) -c $< %.cmx: %.ml $(SHOW)'OCAMLOPT $<' - $(HIDE)$(OCAMLOPT) $(COND_OPTFLAGS) -c $< + $(HIDE)$(OCAMLOPT) $(COND_OPTFLAGS) $(HACKMLI) -c $< %.cmxs: %.cmx $(SHOW)'OCAMLOPT -shared -o $@' @@ -606,15 +604,10 @@ OCAMLDEP = $(OCAMLFIND) ocamldep -slash -ml-synonym .ml4 -ml-synonym .mlpack coqlib: theories plugins theories: $(THEORIESVO) -plugins: $(PLUGINSVO) $(PLUGINSCMO) +plugins: $(PLUGINSVO) .PHONY: coqlib theories plugins -# One of the .v files is macro-generated - -theories/Numbers/Natural/BigN/NMake_gen.v: theories/Numbers/Natural/BigN/NMake_gen.ml - $(OCAML) $< $(TOTARGET) - # The .vo files in Init are built with the -noinit option theories/Init/%.vo theories/Init/%.glob: theories/Init/%.v $(VO_TOOLS_DEP) @@ -622,6 +615,26 @@ theories/Init/%.vo theories/Init/%.glob: theories/Init/%.v $(VO_TOOLS_DEP) $(HIDE)rm -f theories/Init/$*.glob $(HIDE)$(BOOTCOQC) $< $(COQ_XML) -noinit -R theories Coq +# MExtraction.v generates the ml core file of the micromega tactic. +# We check that this generated code is still in sync with the version +# of micromega.ml in the archive. + +# Note: we now dump to stdout there via "Recursive Extraction" for better +# control on the name of the generated file, and avoid a .ml that +# would end in our $(MLFILES). The "sed" below is to kill the final +# blank line printed by Recursive Extraction (unlike Extraction "foo"). + +MICROMEGAV:=plugins/micromega/MExtraction.v +MICROMEGAML:=plugins/micromega/micromega.ml +MICROMEGAGEN:=plugins/micromega/.micromega.ml.generated + +$(MICROMEGAV:.v=.vo) $(MICROMEGAV:.v=.glob) : $(MICROMEGAV) theories/Init/Prelude.vo $(VO_TOOLS_DEP) + $(SHOW)'COQC $<' + $(HIDE)rm -f $*.glob + $(HIDE)$(BOOTCOQC) $< | sed -e '$$d' > $(MICROMEGAGEN) + $(HIDE)cmp -s $(MICROMEGAML) $(MICROMEGAGEN) || \ + echo "Warning: $(MICROMEGAML) and the code generated by $(MICROMEGAV) differ !" + # The general rule for building .vo files : %.vo %.glob: %.v theories/Init/Prelude.vo $(VO_TOOLS_DEP) @@ -636,7 +649,7 @@ endif # Dependencies of .v files -%.v.d: $(D_DEPEND_BEFORE_SRC) %.v $(D_DEPEND_AFTER_SRC) $(COQDEPBOOT) $(GENVFILES) +%.v.d: $(D_DEPEND_BEFORE_SRC) %.v $(D_DEPEND_AFTER_SRC) $(COQDEPBOOT) $(SHOW)'COQDEP $<' $(HIDE)$(COQDEPBOOT) -boot $(DYNDEP) "$<" $(TOTARGET) diff --git a/Makefile.ci b/Makefile.ci index 35eadc7d70..3be90c0a31 100644 --- a/Makefile.ci +++ b/Makefile.ci @@ -1,6 +1,5 @@ CI_TARGETS=ci-all \ - ci-bedrock-facade \ - ci-bedrock-src \ + ci-bignums \ ci-color \ ci-compcert \ ci-coq-dpdgraph \ diff --git a/Makefile.common b/Makefile.common index b2e1d47dfd..ec5e6ac855 100644 --- a/Makefile.common +++ b/Makefile.common @@ -129,8 +129,8 @@ RTAUTOCMO:=plugins/rtauto/rtauto_plugin.cmo NATSYNTAXCMO:=plugins/syntax/nat_syntax_plugin.cmo OTHERSYNTAXCMO:=$(addprefix plugins/syntax/, \ z_syntax_plugin.cmo \ - numbers_syntax_plugin.cmo \ r_syntax_plugin.cmo \ + int31_syntax_plugin.cmo \ ascii_syntax_plugin.cmo \ string_syntax_plugin.cmo ) DERIVECMO:=plugins/derive/derive_plugin.cmo @@ -161,14 +161,8 @@ LINKCMX:=$(CORECMA:.cma=.cmxa) $(STATICPLUGINS:.cmo=.cmx) # vo files ########################################################################### -GENVOFILES := $(GENVFILES:.v=.vo) - -THEORIESVO := $(patsubst %.v,%.vo,$(shell find theories -type f -name "*.v")) \ - $(filter theories/%, $(GENVOFILES)) - -PLUGINSVO := $(patsubst %.v,%.vo,$(shell find plugins -type f -name "*.v")) \ - $(filter plugins/%, $(GENVOFILES)) - +THEORIESVO := $(patsubst %.v,%.vo,$(shell find theories -type f -name "*.v")) +PLUGINSVO := $(patsubst %.v,%.vo,$(shell find plugins -type f -name "*.v")) ALLVO := $(THEORIESVO) $(PLUGINSVO) VFILES := $(ALLVO:.vo=.v) diff --git a/Makefile.dev b/Makefile.dev index 0105df972a..b0299bd160 100644 --- a/Makefile.dev +++ b/Makefile.dev @@ -186,7 +186,7 @@ omega: $(OMEGAVO) $(OMEGACMO) $(ROMEGAVO) $(ROMEGACMO) micromega: $(MICROMEGAVO) $(MICROMEGACMO) $(CSDPCERT) setoid_ring: $(RINGVO) $(RINGCMO) nsatz: $(NSATZVO) $(NSATZCMO) -extraction: $(EXTRACTIONCMO) +extraction: $(EXTRACTIONCMO) $(EXTRACTIONVO) fourier: $(FOURIERVO) $(FOURIERCMO) funind: $(FUNINDCMO) $(FUNINDVO) cc: $(CCVO) $(CCCMO) diff --git a/checker/cic.mli b/checker/cic.mli index 3645587554..e298c41cf1 100644 --- a/checker/cic.mli +++ b/checker/cic.mli @@ -209,7 +209,9 @@ type constant_def = | Def of constr_substituted | OpaqueDef of lazy_constr -type constant_universes = Univ.universe_context +type constant_universes = + | Monomorphic_const of Univ.universe_context + | Polymorphic_const of Univ.abstract_universe_context (** The [typing_flags] are instructions to the type-checker which modify its behaviour. The typing flags used in the type-checking @@ -226,7 +228,6 @@ type constant_body = { const_body : constant_def; const_type : constant_type; const_body_code : to_patch_substituted; - const_polymorphic : bool; (** Is it polymorphic or not *) const_universes : constant_universes; const_proj : projection_body option; const_inline_code : bool; @@ -303,6 +304,11 @@ type one_inductive_body = { mind_reloc_tbl : reloc_table; } +type abstract_inductive_universes = + | Monomorphic_ind of Univ.universe_context + | Polymorphic_ind of Univ.abstract_universe_context + | Cumulative_ind of Univ.abstract_cumulativity_info + type mutual_inductive_body = { mind_packets : one_inductive_body array; (** The component of the mutual inductive block *) @@ -321,9 +327,7 @@ type mutual_inductive_body = { mind_params_ctxt : rel_context; (** The context of parameters (includes let-in declaration) *) - mind_polymorphic : bool; (** Is it polymorphic or not *) - - mind_universes : Univ.universe_context; (** Local universe variables and constraints *) + mind_universes : abstract_inductive_universes; (** Local universe variables and constraints together with subtyping constraints *) mind_private : bool option; (** allow pattern-matching: Some true ok, Some false blocked *) diff --git a/checker/closure.ml b/checker/closure.ml index b8294e7958..ac8388f6ed 100644 --- a/checker/closure.ml +++ b/checker/closure.ml @@ -328,6 +328,12 @@ let zshift n s = | (_,Zshift(k)::s) -> Zshift(n+k)::s | _ -> Zshift(n)::s +let rec stack_args_size = function + | Zapp v :: s -> Array.length v + stack_args_size s + | Zshift(_)::s -> stack_args_size s + | Zupdate(_)::s -> stack_args_size s + | _ -> 0 + (* Lifting. Preserves sharing (useful only for cell with norm=Red). lft_fconstr always create a new cell, while lift_fconstr avoids it when the lift is 0. *) diff --git a/checker/closure.mli b/checker/closure.mli index 8b1f246c28..8da9ad4ea5 100644 --- a/checker/closure.mli +++ b/checker/closure.mli @@ -125,6 +125,9 @@ type stack_member = and stack = stack_member list val append_stack : fconstr array -> stack -> stack + +val stack_args_size : stack -> int + val eta_expand_stack : stack -> stack val eta_expand_ind_stack : env -> inductive -> fconstr -> stack -> diff --git a/checker/declarations.ml b/checker/declarations.ml index ad93146d55..2eefe47816 100644 --- a/checker/declarations.ml +++ b/checker/declarations.ml @@ -521,6 +521,11 @@ let subst_template_cst_arity sub (ctx,s as arity) = let subst_arity sub s = subst_decl_arity subst_mps subst_template_cst_arity sub s +let constant_is_polymorphic cb = + match cb.const_universes with + | Monomorphic_const _ -> false + | Polymorphic_const _ -> true + (* TODO: should be changed to non-coping after Term.subst_mps *) (* NB: we leave bytecode and native code fields untouched *) let subst_const_body sub cb = diff --git a/checker/declarations.mli b/checker/declarations.mli index 456df83699..6fc71bb942 100644 --- a/checker/declarations.mli +++ b/checker/declarations.mli @@ -14,6 +14,7 @@ val body_of_constant : constant_body -> constr option val constant_has_body : constant_body -> bool val is_opaque : constant_body -> bool val opaque_univ_context : constant_body -> Univ.ContextSet.t +val constant_is_polymorphic : constant_body -> bool (* Mutual inductives *) diff --git a/checker/environ.ml b/checker/environ.ml index 22d1eec178..11b8ea67cc 100644 --- a/checker/environ.ml +++ b/checker/environ.ml @@ -115,13 +115,15 @@ let add_constant kn cs env = env_constants = new_constants } in { env with env_globals = new_globals } -type const_evaluation_result = NoBody | Opaque +type const_evaluation_result = NoBody | Opaque | IsProj (* Constant types *) let constraints_of cb u = - let univs = cb.const_universes in - Univ.subst_instance_constraints u (Univ.UContext.constraints univs) + match cb.const_universes with + | Monomorphic_const _ -> Univ.Constraint.empty + | Polymorphic_const ctx -> + Univ.UContext.constraints (Univ.subst_instance_context u ctx) let map_regular_arity f = function | RegularArity a as ar -> @@ -132,23 +134,28 @@ let map_regular_arity f = function (* constant_type gives the type of a constant *) let constant_type env (kn,u) = let cb = lookup_constant kn env in - if cb.const_polymorphic then - let csts = constraints_of cb u in - (map_regular_arity (subst_instance_constr u) cb.const_type, csts) - else cb.const_type, Univ.Constraint.empty + match cb.const_universes with + | Monomorphic_const _ -> cb.const_type, Univ.Constraint.empty + | Polymorphic_const ctx -> + let csts = constraints_of cb u in + (map_regular_arity (subst_instance_constr u) cb.const_type, csts) exception NotEvaluableConst of const_evaluation_result let constant_value env (kn,u) = let cb = lookup_constant kn env in + if cb.const_proj = None then match cb.const_body with | Def l_body -> let b = force_constr l_body in - if cb.const_polymorphic then - subst_instance_constr u (force_constr l_body) - else b + begin + match cb.const_universes with + | Monomorphic_const _ -> b + | Polymorphic_const _ -> subst_instance_constr u (force_constr l_body) + end | OpaqueDef _ -> raise (NotEvaluableConst Opaque) | Undef _ -> raise (NotEvaluableConst NoBody) + else raise (NotEvaluableConst IsProj) (* A global const is evaluable if it is defined and not opaque *) let evaluable_constant cst env = diff --git a/checker/environ.mli b/checker/environ.mli index 87f143d1bb..754c295d27 100644 --- a/checker/environ.mli +++ b/checker/environ.mli @@ -47,7 +47,7 @@ val check_constraints : Univ.constraints -> env -> bool val lookup_constant : constant -> env -> Cic.constant_body val add_constant : constant -> Cic.constant_body -> env -> env val constant_type : env -> constant puniverses -> constant_type Univ.constrained -type const_evaluation_result = NoBody | Opaque +type const_evaluation_result = NoBody | Opaque | IsProj exception NotEvaluableConst of const_evaluation_result val constant_value : env -> constant puniverses -> constr val evaluable_constant : constant -> env -> bool diff --git a/checker/indtypes.ml b/checker/indtypes.ml index 6c38f38e29..54dec56b54 100644 --- a/checker/indtypes.ml +++ b/checker/indtypes.ml @@ -524,13 +524,67 @@ let check_positivity env_ar mind params nrecp inds = let wfp = Rtree.mk_rec irecargs in Array.iter2 (fun ind wfpi -> check_subtree ind.mind_recargs wfpi) inds wfp +(* Check arities and constructors *) +let check_subtyping_arity_constructor env (subst : constr -> constr) (arcn : constr) numparams is_arity = + let numchecked = ref 0 in + let basic_check ev tp = + if !numchecked < numparams then () else conv_leq ev tp (subst tp); + numchecked := !numchecked + 1 + in + let check_typ typ typ_env = + match typ with + | LocalAssum (_, typ') -> + begin + try + basic_check typ_env typ'; Environ.push_rel typ typ_env + with NotConvertible -> + anomaly ~label:"bad inductive subtyping relation" (Pp.str "Invalid subtyping relation") + end + | _ -> anomaly (Pp.str "") + in + let typs, codom = dest_prod env arcn in + let last_env = fold_rel_context_outside check_typ typs ~init:env in + if not is_arity then basic_check last_env codom else () + +(* Check that the subtyping information inferred for inductive types in the block is correct. *) +(* This check produces a value of the unit type if successful or raises an anomaly if check fails. *) +let check_subtyping cumi paramsctxt env_ar inds = + let numparams = rel_context_nhyps paramsctxt in + let sbsubst = Univ.CumulativityInfo.subtyping_susbst cumi in + let other_instnace = Univ.CumulativityInfo.subtyping_other_instance cumi in + let dosubst = subst_univs_level_constr sbsubst in + let uctx = Univ.CumulativityInfo.univ_context cumi in + let uctx_other = Univ.UContext.make (other_instnace, Univ.UContext.constraints uctx) in + let env = Environ.push_context uctx env_ar + in + let env = Environ.push_context uctx_other env + in + let env = Environ.push_context + (Univ.CumulativityInfo.subtyp_context cumi) env + in + (* process individual inductive types: *) + Array.iter (fun { mind_user_lc = lc; mind_arity = arity } -> + match arity with + | RegularArity { mind_user_arity = full_arity} -> + check_subtyping_arity_constructor env dosubst full_arity numparams true; + Array.iter (fun cnt -> check_subtyping_arity_constructor env dosubst cnt numparams false) lc + | TemplateArity _ -> () + ) inds + (************************************************************************) (************************************************************************) let check_inductive env kn mib = Flags.if_verbose Feedback.msg_notice (str " checking ind: " ++ MutInd.print kn); (* check mind_constraints: should be consistent with env *) - let env = Environ.push_context (Univ.instantiate_univ_context mib.mind_universes) env in + let ind_ctx = + match mib.mind_universes with + | Monomorphic_ind ctx -> ctx + | Polymorphic_ind auctx -> Univ.instantiate_univ_context auctx + | Cumulative_ind cumi -> + Univ.instantiate_univ_context (Univ.ACumulativityInfo.univ_context cumi) + in + let env = Environ.push_context ind_ctx env in (* check mind_record : TODO ? check #constructor = 1 ? *) (* check mind_finite : always OK *) (* check mind_ntypes *) @@ -547,6 +601,14 @@ let check_inductive env kn mib = let env_ar = typecheck_arity env params mib.mind_packets in (* - check constructor types *) Array.iter (typecheck_one_inductive env_ar params mib) mib.mind_packets; + (* check the inferred subtyping relation *) + let () = + match mib.mind_universes with + | Monomorphic_ind _ | Polymorphic_ind _ -> () + | Cumulative_ind acumi -> + check_subtyping + (Univ.instantiate_cumulativity_info acumi) params env_ar mib.mind_packets + in (* check mind_nparams_rec: positivity condition *) check_positivity env_ar kn params mib.mind_nparams_rec mib.mind_packets; (* check mind_equiv... *) diff --git a/checker/inductive.ml b/checker/inductive.ml index f890adba9a..e1860a23f0 100644 --- a/checker/inductive.ml +++ b/checker/inductive.ml @@ -54,10 +54,31 @@ let inductive_params (mib,_) = mib.mind_nparams (** Polymorphic inductives *) -let inductive_instance mib = - if mib.mind_polymorphic then - UContext.instance mib.mind_universes - else Instance.empty +let inductive_is_polymorphic mib = + match mib.mind_universes with + | Monomorphic_ind _ -> false + | Polymorphic_ind ctx -> true + | Cumulative_ind cumi -> true + +let inductive_is_cumulative mib = + match mib.mind_universes with + | Monomorphic_ind _ -> false + | Polymorphic_ind ctx -> false + | Cumulative_ind cumi -> true + +let inductive_polymorphic_instance mib = + match mib.mind_universes with + | Monomorphic_ind _ -> Univ.Instance.empty + | Polymorphic_ind ctx -> Univ.AUContext.instance ctx + | Cumulative_ind cumi -> + Univ.AUContext.instance (Univ.ACumulativityInfo.univ_context cumi) + +let inductive_polymorphic_context mib = + match mib.mind_universes with + | Monomorphic_ind _ -> Univ.UContext.empty + | Polymorphic_ind ctx -> Univ.instantiate_univ_context ctx + | Cumulative_ind cumi -> + Univ.instantiate_univ_context (Univ.ACumulativityInfo.univ_context cumi) (************************************************************************) @@ -93,7 +114,7 @@ let instantiate_params full t u args sign = let full_inductive_instantiate mib u params sign = let dummy = Prop Null in - let t = mkArity (subst_instance_context u sign,dummy) in + let t = mkArity (Term.subst_instance_context u sign,dummy) in fst (destArity (instantiate_params true t u params mib.mind_params_ctxt)) let full_constructor_instantiate ((mind,_),u,(mib,_),params) t = @@ -199,7 +220,7 @@ let instantiate_universes env ctx ar argsorts = let type_of_inductive_gen env ((mib,mip),u) paramtyps = match mip.mind_arity with | RegularArity a -> - if not mib.mind_polymorphic then a.mind_user_arity + if not (inductive_is_polymorphic mib) then a.mind_user_arity else subst_instance_constr u a.mind_user_arity | TemplateArity ar -> let ctx = List.rev mip.mind_arity_ctxt in diff --git a/checker/inductive.mli b/checker/inductive.mli index ed3a7b53ce..9a5541f39b 100644 --- a/checker/inductive.mli +++ b/checker/inductive.mli @@ -22,7 +22,13 @@ type mind_specif = mutual_inductive_body * one_inductive_body Raises [Not_found] if the inductive type is not found. *) val lookup_mind_specif : env -> inductive -> mind_specif -val inductive_instance : mutual_inductive_body -> Univ.universe_instance +val inductive_is_polymorphic : mutual_inductive_body -> bool + +val inductive_is_cumulative : mutual_inductive_body -> bool + +val inductive_polymorphic_instance : mutual_inductive_body -> Univ.universe_instance + +val inductive_polymorphic_context : mutual_inductive_body -> Univ.universe_context val type_of_inductive : env -> mind_specif puniverses -> constr diff --git a/checker/mod_checking.ml b/checker/mod_checking.ml index 7f93e15609..15e9ae2951 100644 --- a/checker/mod_checking.ml +++ b/checker/mod_checking.ml @@ -1,4 +1,3 @@ - open Pp open Util open Names @@ -26,21 +25,23 @@ let refresh_arity ar = | _ -> ar, Univ.ContextSet.empty let check_constant_declaration env kn cb = - Flags.if_verbose Feedback.msg_notice (str " checking cst: " ++ prcon kn); - let env' = - if cb.const_polymorphic then - let inst = Univ.make_abstract_instance cb.const_universes in - let ctx = Univ.UContext.make (inst, Univ.UContext.constraints cb.const_universes) in - push_context ~strict:false ctx env - else push_context ~strict:true cb.const_universes env + Feedback.msg_notice (str " checking cst:" ++ prcon kn); + let env', u = + match cb.const_universes with + | Monomorphic_const ctx -> push_context ~strict:true ctx env, Univ.Instance.empty + | Polymorphic_const auctx -> + let ctx = Univ.instantiate_univ_context auctx in + push_context ~strict:false ctx env, Univ.UContext.instance ctx in let envty, ty = match cb.const_type with RegularArity ty -> + let ty = subst_instance_constr u ty in let ty', cu = refresh_arity ty in let envty = push_context_set cu env' in let _ = infer_type envty ty' in envty, ty | TemplateArity(ctxt,par) -> + assert(Univ.Instance.is_empty u); let _ = check_ctxt env' ctxt in check_polymorphic_arity env' ctxt par; env', it_mkProd_or_LetIn (Sort(Type par.template_level)) ctxt @@ -48,6 +49,7 @@ let check_constant_declaration env kn cb = let () = match body_of_constant cb with | Some bd -> + let bd = subst_instance_constr u bd in (match cb.const_proj with | None -> let j = infer envty bd in conv_leq envty j ty @@ -57,7 +59,7 @@ let check_constant_declaration env kn cb = conv_leq envty j ty) | None -> () in - if cb.const_polymorphic then add_constant kn cb env + if constant_is_polymorphic cb then add_constant kn cb env else add_constant kn cb env' (** {6 Checking modules } *) diff --git a/checker/modops.ml b/checker/modops.ml index bed31143bf..be35c7e981 100644 --- a/checker/modops.ml +++ b/checker/modops.ml @@ -83,10 +83,10 @@ let strengthen_const mp_from l cb resolver = | Def _ -> cb | _ -> let con = Constant.make2 mp_from l in - let u = - if cb.const_polymorphic then - Univ.make_abstract_instance cb.const_universes - else Univ.Instance.empty + let u = + match cb.const_universes with + | Monomorphic_const _ -> Univ.Instance.empty + | Polymorphic_const auctx -> Univ.make_abstract_instance auctx in { cb with const_body = Def (Declarations.from_val (Const (con,u))) } diff --git a/checker/reduction.ml b/checker/reduction.ml index ba0b017844..95dc93f5d2 100644 --- a/checker/reduction.ml +++ b/checker/reduction.ml @@ -117,6 +117,10 @@ let beta_appvect c v = (* Conversion *) (********************************************************************) +type conv_pb = + | CONV + | CUMUL + (* Conversion utility functions *) type 'a conversion_function = env -> 'a -> 'a -> unit @@ -152,11 +156,62 @@ let compare_stacks f fmind lft1 stk1 lft2 stk2 = cmp_rec (pure_stack lft1 stk1) (pure_stack lft2 stk2) else raise NotConvertible -(* Convertibility of sorts *) +let convert_inductive_instances cv_pb cumi u u' univs = + let ind_instance = + Univ.AUContext.instance (Univ.ACumulativityInfo.univ_context cumi) in + let ind_subtypctx = Univ.ACumulativityInfo.subtyp_context cumi in + if not ((Univ.Instance.length ind_instance = Univ.Instance.length u) && + (Univ.Instance.length ind_instance = Univ.Instance.length u')) then + anomaly (Pp.str "Invalid inductive subtyping encountered!") + else + let comp_cst = + let comp_subst = (Univ.Instance.append u u') in + Univ.UContext.constraints + (Univ.subst_instance_context comp_subst ind_subtypctx) + in + let comp_cst = + match cv_pb with + CONV -> + let comp_cst' = + let comp_subst = (Univ.Instance.append u' u) in + Univ.UContext.constraints + (Univ.subst_instance_context comp_subst ind_subtypctx) + in + Univ.Constraint.union comp_cst comp_cst' + | CUMUL -> comp_cst + in + if (Univ.check_constraints comp_cst univs) then () else raise NotConvertible + +let convert_inductives + cv_pb (mind, ind) u1 sv1 u2 sv2 univs = + match mind.mind_universes with + | Monomorphic_ind _ | Polymorphic_ind _ -> convert_universes univs u1 u2 + | Cumulative_ind cumi -> + let num_param_arity = + mind.mind_nparams + mind.mind_packets.(ind).mind_nrealargs + in + if not (num_param_arity = sv1 && num_param_arity = sv2) then + convert_universes univs u1 u2 + else + convert_inductive_instances cv_pb cumi u1 u2 univs + +let convert_constructors + (mind, ind, cns) u1 sv1 u2 sv2 univs = + match mind.mind_universes with + | Monomorphic_ind _ | Polymorphic_ind _ -> convert_universes univs u1 u2 + | Cumulative_ind cumi -> + let num_cnstr_args = + let nparamsctxt = + mind.mind_nparams + mind.mind_packets.(ind).mind_nrealargs + in + nparamsctxt + mind.mind_packets.(ind).mind_consnrealargs.(cns - 1) + in + if not (num_cnstr_args = sv1 && num_cnstr_args = sv2) then + convert_universes univs u1 u2 + else + convert_inductive_instances CONV cumi u1 u2 univs -type conv_pb = - | CONV - | CUMUL +(* Convertibility of sorts *) let sort_cmp env univ pb s0 s1 = match (s0,s1) with @@ -375,18 +430,37 @@ and eqappr univ cv_pb infos (lft1,st1) (lft2,st2) = (* Inductive types: MutInd MutConstruct Fix Cofix *) | (FInd (ind1,u1), FInd (ind2,u2)) -> - if mind_equiv_infos infos ind1 ind2 - then - (let () = convert_universes univ u1 u2 in - convert_stacks univ infos lft1 lft2 v1 v2) - else raise NotConvertible - - | (FConstruct ((ind1,j1),u1), FConstruct ((ind2,j2),u2)) -> - if Int.equal j1 j2 && mind_equiv_infos infos ind1 ind2 - then - (let () = convert_universes univ u1 u2 in - convert_stacks univ infos lft1 lft2 v1 v2) - else raise NotConvertible + if mind_equiv_infos infos ind1 ind2 then + if Univ.Instance.length u1 = 0 || Univ.Instance.length u2 = 0 then + begin + convert_universes univ u1 u2; + convert_stacks univ infos lft1 lft2 v1 v2 + end + else + let mind = Environ.lookup_mind (fst ind1) (infos_env infos) in + let () = + convert_inductives cv_pb (mind, snd ind1) u1 (stack_args_size v1) + u2 (stack_args_size v2) univ + in + convert_stacks univ infos lft1 lft2 v1 v2 + else raise NotConvertible + + | (FConstruct ((ind1,j1),u1), FConstruct ((ind2,j2),u2)) -> + if Int.equal j1 j2 && mind_equiv_infos infos ind1 ind2 then + if Univ.Instance.length u1 = 0 || Univ.Instance.length u2 = 0 then + begin + convert_universes univ u1 u2; + convert_stacks univ infos lft1 lft2 v1 v2 + end + else + let mind = Environ.lookup_mind (fst ind1) (infos_env infos) in + let () = + convert_constructors + (mind, snd ind1, j1) u1 (stack_args_size v1) + u2 (stack_args_size v2) univ + in + convert_stacks univ infos lft1 lft2 v1 v2 + else raise NotConvertible (* Eta expansion of records *) | (FConstruct ((ind1,j1),u1), _) -> diff --git a/checker/subtyping.ml b/checker/subtyping.ml index 2d04b77e46..bfe19584a7 100644 --- a/checker/subtyping.ml +++ b/checker/subtyping.ml @@ -88,18 +88,25 @@ let check_inductive env mp1 l info1 mib2 spec2 subst1 subst2= let check_conv f = check_conv_error error f in let mib1 = match info1 with - | IndType ((_,0), mib) -> mib + | IndType ((_,0), mib) -> subst_mind subst1 mib | _ -> error () in let mib2 = subst_mind subst2 mib2 in let check eq f = if not (eq (f mib1) (f mib2)) then error () in - let bool_equal (x : bool) (y : bool) = x = y in - let u = - check bool_equal (fun x -> x.mind_polymorphic); - if mib1.mind_polymorphic then ( - check Univ.Instance.equal (fun x -> Univ.UContext.instance x.mind_universes); - Univ.UContext.instance mib1.mind_universes) - else Univ.Instance.empty + let u = + let process inst inst' = + if Univ.Instance.equal inst inst' then inst else error () + in + match mib1.mind_universes, mib2.mind_universes with + | Monomorphic_ind _, Monomorphic_ind _ -> Univ.Instance.empty + | Polymorphic_ind auctx, Polymorphic_ind auctx' -> + process + (Univ.AUContext.instance auctx) (Univ.AUContext.instance auctx') + | Cumulative_ind cumi, Cumulative_ind cumi' -> + process + (Univ.AUContext.instance (Univ.ACumulativityInfo.univ_context cumi)) + (Univ.AUContext.instance (Univ.ACumulativityInfo.univ_context cumi')) + | _ -> error () in let eq_projection_body p1 p2 = let check eq f = if not (eq (f p1) (f p2)) then error () in @@ -308,7 +315,7 @@ let check_constant env mp1 l info1 cb2 spec2 subst1 subst2 = "inductive type and give a definition to map the old name to the new " ^ "name."))); if constant_has_body cb2 then error () ; - let u = inductive_instance mind1 in + let u = inductive_polymorphic_instance mind1 in let arity1 = type_of_inductive env ((mind1,mind1.mind_packets.(i)),u) in let typ2 = Typeops.type_of_constant_type env cb2.const_type in check_conv conv_leq env arity1 typ2 @@ -319,7 +326,7 @@ let check_constant env mp1 l info1 cb2 spec2 subst1 subst2 = "constructor and give a definition to map the old name to the new " ^ "name."))); if constant_has_body cb2 then error () ; - let u1 = inductive_instance mind1 in + let u1 = inductive_polymorphic_instance mind1 in let ty1 = type_of_constructor (cstr,u1) (mind1,mind1.mind_packets.(i)) in let ty2 = Typeops.type_of_constant_type env cb2.const_type in check_conv conv env ty1 ty2 diff --git a/checker/term.ml b/checker/term.ml index 75c566aeb7..dea3d3e659 100644 --- a/checker/term.ml +++ b/checker/term.ml @@ -227,6 +227,8 @@ let rel_context_nhyps hyps = nhyps 0 hyps let fold_rel_context f l ~init = List.fold_right f l init +let fold_rel_context_outside f l ~init = List.fold_right f l init + let map_rel_decl f = function | LocalAssum (n, typ) as decl -> let typ' = f typ in @@ -414,6 +416,42 @@ let subst_instance_constr subst c = if Univ.Instance.is_empty subst then c else let f u = Univ.subst_instance_instance subst u in + let rec aux t = + match t with + | Const (c, u) -> + if Univ.Instance.is_empty u then t + else + let u' = f u in + if u' == u then t + else (Const (c, u')) + | Ind (i, u) -> + if Univ.Instance.is_empty u then t + else + let u' = f u in + if u' == u then t + else (Ind (i, u')) + | Construct (c, u) -> + if Univ.Instance.is_empty u then t + else + let u' = f u in + if u' == u then t + else (Construct (c, u')) + | Sort (Type u) -> + let u' = Univ.subst_instance_universe subst u in + if u' == u then t else + (Sort (sort_of_univ u')) + | _ -> map_constr aux t + in + aux c + +let subst_instance_context s ctx = + if Univ.Instance.is_empty s then ctx + else map_rel_context (fun x -> subst_instance_constr s x) ctx + +let subst_univs_level_constr subst c = + if Univ.is_empty_level_subst subst then c + else + let f = Univ.Instance.subst_fn (Univ.subst_univs_level_level subst) in let changed = ref false in let rec aux t = match t with @@ -436,14 +474,10 @@ let subst_instance_constr subst c = if u' == u then t else (changed := true; Construct (c, u')) | Sort (Type u) -> - let u' = Univ.subst_instance_universe subst u in + let u' = Univ.subst_univs_level_universe subst u in if u' == u then t else (changed := true; Sort (sort_of_univ u')) | _ -> map_constr aux t in let c' = aux c in if !changed then c' else c - -let subst_instance_context s ctx = - if Univ.Instance.is_empty s then ctx - else map_rel_context (fun x -> subst_instance_constr s x) ctx diff --git a/checker/term.mli b/checker/term.mli index 6b026d056f..ccf5b59e0c 100644 --- a/checker/term.mli +++ b/checker/term.mli @@ -33,6 +33,8 @@ val rel_context_length : rel_context -> int val rel_context_nhyps : rel_context -> int val fold_rel_context : (rel_declaration -> 'a -> 'a) -> rel_context -> init:'a -> 'a +val fold_rel_context_outside : + (rel_declaration -> 'a -> 'a) -> rel_context -> init:'a -> 'a val map_rel_decl : (constr -> constr) -> rel_declaration -> rel_declaration val map_rel_context : (constr -> constr) -> rel_context -> rel_context val extended_rel_list : int -> rel_context -> constr list @@ -55,3 +57,4 @@ val eq_constr : constr -> constr -> bool (** Instance substitution for polymorphism. *) val subst_instance_constr : Univ.universe_instance -> constr -> constr val subst_instance_context : Univ.universe_instance -> rel_context -> rel_context +val subst_univs_level_constr : Univ.universe_level_subst -> constr -> constr diff --git a/checker/typeops.ml b/checker/typeops.ml index 0163db3347..543f9acced 100644 --- a/checker/typeops.ml +++ b/checker/typeops.ml @@ -329,7 +329,6 @@ let rec execute env cstr = let pj = execute env p in let lfj = execute_array env lf in judge_of_case env ci (p,pj) (c,cj) lfj - | Fix ((_,i as vni),recdef) -> let fix_ty = execute_recdef env recdef i in let fix = (vni,recdef) in diff --git a/checker/univ.ml b/checker/univ.ml index 5717432315..0ee4686c1a 100644 --- a/checker/univ.ml +++ b/checker/univ.ml @@ -968,7 +968,23 @@ struct else Level.compare v v' end -module Constraint = Set.Make(UConstraintOrd) +let pr_constraint_type op = + let op_str = match op with + | Lt -> " < " + | Le -> " <= " + | Eq -> " = " + in str op_str + +module Constraint = +struct + module S = Set.Make(UConstraintOrd) + include S + + let pr prl c = + fold (fun (u1,op,u2) pp_std -> + pp_std ++ prl u1 ++ pr_constraint_type op ++ + prl u2 ++ fnl () ) c (str "") +end let empty_constraint = Constraint.empty let merge_constraints c g = @@ -1056,7 +1072,9 @@ module Instance : sig val subst_fn : universe_level_subst_fn -> t -> t val subst : universe_level_subst -> t -> t val pr : t -> Pp.std_ppcmds - val check_eq : t check_function + val check_eq : t check_function + val length : t -> int + val append : t -> t -> t end = struct type t = Level.t array @@ -1099,6 +1117,7 @@ struct (* [h] must be positive. *) let h = !accu land 0x3FFFFFFF in h + end module HInstance = Hashcons.Make(HInstancestruct) @@ -1135,6 +1154,10 @@ struct (Int.equal i (Array.length t1)) || (check_eq_level g t1.(i) t2.(i) && aux (i + 1)) in aux 0) + let length = Array.length + + let append = Array.append + end type universe_instance = Instance.t @@ -1152,10 +1175,63 @@ struct let make x = x let instance (univs, cst) = univs let constraints (univs, cst) = cst + + let is_empty (univs, cst) = Instance.is_empty univs && Constraint.is_empty cst + let pr prl (univs, cst as ctx) = + if is_empty ctx then mt() else + h 0 (Instance.pr univs ++ str " |= ") ++ h 0 (v 0 (Constraint.pr prl cst)) end type universe_context = UContext.t +module AUContext = UContext + +type abstract_universe_context = AUContext.t + +module CumulativityInfo = +struct + type t = universe_context * universe_context + + let make x = + if (Array.length (UContext.instance (snd x))) = + (Array.length (UContext.instance (fst x))) * 2 then x + else anomaly (Pp.str "Invalid subtyping information encountered!") + + let empty = (UContext.empty, UContext.empty) + + let halve_context ctx = + let len = Array.length ctx in + let halflen = len / 2 in + ((Array.sub ctx 0 halflen), (Array.sub ctx halflen halflen)) + + let univ_context (univcst, subtypcst) = univcst + let subtyp_context (univcst, subtypcst) = subtypcst + + let create_trivial_subtyping ctx ctx' = + CArray.fold_left_i + (fun i cst l -> Constraint.add (l, Eq, Array.get ctx' i) cst) + Constraint.empty ctx + + let from_universe_context univcst freshunivs = + let inst = (UContext.instance univcst) in + assert (Array.length freshunivs = Array.length inst); + (univcst, UContext.make (Array.append inst freshunivs, + create_trivial_subtyping inst freshunivs)) + + let subtyping_other_instance (univcst, subtypcst) = + let (_, ctx') = (halve_context (UContext.instance subtypcst)) in ctx' + + let subtyping_susbst (univcst, subtypcst) = + let (ctx, ctx') = (halve_context (UContext.instance subtypcst)) in + Array.fold_left2 (fun subst l1 l2 -> LMap.add l1 l2 subst) LMap.empty ctx ctx' + +end + +type cumulativity_info = CumulativityInfo.t + +module ACumulativityInfo = CumulativityInfo +type abstract_cumulativity_info = ACumulativityInfo.t + module ContextSet = struct type t = LSet.t constrained @@ -1166,6 +1242,8 @@ struct end type universe_context_set = ContextSet.t + + (** Substitutions. *) let is_empty_subst = LMap.is_empty @@ -1210,7 +1288,10 @@ let subst_instance_constraint s (u,d,v as c) = let subst_instance_constraints s csts = Constraint.fold (fun c csts -> Constraint.add (subst_instance_constraint s c) csts) - csts Constraint.empty + csts Constraint.empty + +let subst_instance_context inst (inner_inst, inner_constr) = + (inner_inst, subst_instance_constraints inst inner_constr) let make_abstract_instance (ctx, _) = Array.mapi (fun i l -> Level.var i) ctx @@ -1219,8 +1300,8 @@ let make_abstract_instance (ctx, _) = let instantiate_univ_context (ctx, csts) = (ctx, subst_instance_constraints ctx csts) -let instantiate_univ_constraints u (_, csts) = - subst_instance_constraints u csts +let instantiate_cumulativity_info (ctx, ctx') = + (instantiate_univ_context ctx, instantiate_univ_context ctx') (** With level to universe substitutions. *) type universe_subst_fn = universe_level -> universe @@ -1262,6 +1343,10 @@ let merge_context_set strict ctx g = (** Pretty-printing *) +let pr_constraints prl = Constraint.pr prl + +let pr_universe_context = UContext.pr + let pr_arc = function | _, Canonical {univ=u; lt=[]; le=[]} -> mt () diff --git a/checker/univ.mli b/checker/univ.mli index 7d4c629ab9..a503924708 100644 --- a/checker/univ.mli +++ b/checker/univ.mli @@ -18,6 +18,9 @@ sig (** Create a new universe level from a unique identifier and an associated module path. *) + val pr : t -> Pp.std_ppcmds + (** Pretty-printing *) + val equal : t -> t -> bool end @@ -71,6 +74,8 @@ type 'a check_function = universes -> 'a -> 'a -> bool val check_leq : universe check_function val check_eq : universe check_function + + (** The initial graph of universes: Prop < Set *) val initial_universes : universes @@ -170,6 +175,12 @@ sig val check_eq : t check_function (** Check equality of instances w.r.t. a universe graph *) + + val length : t -> int + (** Compute the length of the instance *) + + val append : t -> t -> t + (** Append two universe instances *) end type universe_instance = Instance.t @@ -187,9 +198,54 @@ sig val make : universe_instance constrained -> t val instance : t -> Instance.t val constraints : t -> constraints + val is_empty : t -> bool + +end + +type universe_context = UContext.t + +module AUContext : +sig + type t + + val instance : t -> Instance.t + +end + +type abstract_universe_context = AUContext.t + +module CumulativityInfo : +sig + type t + + val make : universe_context * universe_context -> t + + val empty : t + + val univ_context : t -> universe_context + val subtyp_context : t -> universe_context + + val from_universe_context : universe_context -> universe_instance -> t + + val subtyping_other_instance : t -> universe_instance + + val subtyping_susbst : t -> universe_level_subst + +end + +type cumulativity_info = CumulativityInfo.t + +module ACumulativityInfo : +sig + type t + + val univ_context : t -> abstract_universe_context + val subtyp_context : t -> abstract_universe_context end +type abstract_cumulativity_info = ACumulativityInfo.t + module ContextSet : sig type t @@ -198,7 +254,6 @@ module ContextSet : val constraints : t -> constraints end -type universe_context = UContext.t type universe_context_set = ContextSet.t val merge_context : bool -> universe_context -> universes -> universes @@ -221,18 +276,22 @@ val subst_univs_universe : universe_subst_fn -> universe -> universe (** Substitution of instances *) val subst_instance_instance : universe_instance -> universe_instance -> universe_instance val subst_instance_universe : universe_instance -> universe -> universe -val subst_instance_constraints : universe_instance -> constraints -> constraints +val subst_instance_context : universe_instance -> abstract_universe_context -> universe_context (* val make_instance_subst : universe_instance -> universe_level_subst *) (* val make_inverse_instance_subst : universe_instance -> universe_level_subst *) (** Get the instantiated graph. *) -val instantiate_univ_context : universe_context -> universe_context -val instantiate_univ_constraints : universe_instance -> universe_context -> constraints +val instantiate_univ_context : abstract_universe_context -> universe_context +val instantiate_cumulativity_info : abstract_cumulativity_info -> cumulativity_info (** Build the relative instance corresponding to the context *) -val make_abstract_instance : universe_context -> universe_instance +val make_abstract_instance : abstract_universe_context -> universe_instance (** {6 Pretty-printing of universes. } *) +val pr_constraint_type : constraint_type -> Pp.std_ppcmds +val pr_constraints : (Level.t -> Pp.std_ppcmds) -> constraints -> Pp.std_ppcmds +val pr_universe_context : (Level.t -> Pp.std_ppcmds) -> universe_context -> Pp.std_ppcmds + val pr_universes : universes -> Pp.std_ppcmds diff --git a/checker/values.ml b/checker/values.ml index c175aed680..b8b395aaf7 100644 --- a/checker/values.ml +++ b/checker/values.ml @@ -13,7 +13,7 @@ To ensure this file is up-to-date, 'make' now compares the md5 of cic.mli with a copy we maintain here: -MD5 6466d8cc443b5896cb905776df0cc49e checker/cic.mli +MD5 b132075590daf5e202de0d9cc34e6003 checker/cic.mli *) @@ -109,6 +109,8 @@ let v_cstrs = let v_instance = Annot ("instance", Array v_level) let v_context = v_tuple "universe_context" [|v_instance;v_cstrs|] +let v_abs_context = v_context (* only for clarity *) +let v_abs_cum_info = v_tuple "cumulativity_info" [|v_abs_context; v_context|] let v_context_set = v_tuple "universe_context_set" [|v_hset v_level;v_cstrs|] (** kernel/term *) @@ -215,13 +217,14 @@ let v_projbody = let v_typing_flags = v_tuple "typing_flags" [|v_bool; v_bool|] +let v_const_univs = v_sum "constant_universes" 0 [|[|v_context|]; [|v_abs_context|]|] + let v_cb = v_tuple "constant_body" [|v_section_ctxt; v_cst_def; v_cst_type; Any; - v_bool; - v_context; + v_const_univs; Opt v_projbody; v_bool; v_typing_flags|] @@ -262,6 +265,10 @@ let v_finite = v_enum "recursivity_kind" 3 let v_mind_record = Annot ("mind_record", Opt (Opt (v_tuple "record" [| v_id; Array v_cst; Array v_projbody |]))) +let v_ind_pack_univs = + v_sum "abstract_inductive_universes" 0 + [|[|v_context|]; [|v_abs_context|]; [|v_abs_cum_info|]|] + let v_ind_pack = v_tuple "mutual_inductive_body" [|Array v_one_ind; v_mind_record; @@ -271,8 +278,7 @@ let v_ind_pack = v_tuple "mutual_inductive_body" Int; Int; v_rctxt; - v_bool; - v_context; + v_ind_pack_univs; (* universes *) Opt v_bool; v_typing_flags|] diff --git a/configure.ml b/configure.ml index 316cea5c93..549b32772b 100644 --- a/configure.ml +++ b/configure.ml @@ -301,33 +301,37 @@ let args_options = Arg.align [ "-emacslib", arg_string_option Prefs.emacslib, "<dir> Where to install emacs files"; "-emacs", Arg.String (fun s -> - printf "Warning: obsolete -emacs option\n"; + prerr_endline "Warning: -emacs option is deprecated. Use -emacslib instead."; Prefs.emacslib := Some s), - "<dir> Obsolete: same as -emacslib"; + "<dir> Deprecated: same as -emacslib"; "-coqdocdir", arg_string_option Prefs.coqdocdir, "<dir> Where to install Coqdoc style files"; "-ocamlfind", arg_string_option Prefs.ocamlfindcmd, "<dir> Specifies the ocamlfind command to use"; "-lablgtkdir", arg_string_option Prefs.lablgtkdir, "<dir> Specifies the path to the Lablgtk library"; - "-usecamlp5", Arg.Unit (fun () -> ()), - "Deprecated"; + "-usecamlp5", Arg.Unit (fun () -> + prerr_endline "Warning: -usecamlp5 option is deprecated. Camlp5 is already a required dependency."), + " Deprecated: Camlp5 is a required dependency (Camlp4 is not supported anymore)"; "-camlp5dir", Arg.String (fun s -> Prefs.camlp5dir:=Some s), "<dir> Specifies where is the Camlp5 library and tells to use it"; "-arch", arg_string_option Prefs.arch, "<arch> Specifies the architecture"; - "-opt", Arg.Unit (fun () -> printf "Warning: obsolete -opt option\n"), - " Obsolete: native OCaml executables detected automatically"; + "-opt", Arg.Unit (fun () -> + prerr_endline "Warning: -opt option is deprecated. Native OCaml executables are detected automatically."), + " Deprecated: native OCaml executables detected automatically"; "-natdynlink", arg_bool Prefs.natdynlink, "(yes|no) Use dynamic loading of native code or not"; "-coqide", Arg.String (fun s -> Prefs.coqide := Some (get_ide s)), - "(opt|byte|no) Specifies whether or not to compile Coqide"; + "(opt|byte|no) Specifies whether or not to compile CoqIDE"; "-nomacintegration", Arg.Clear Prefs.macintegration, - " Do not try to build coqide mac integration"; + " Do not try to build CoqIDE MacOS integration"; "-browser", arg_string_option Prefs.browser, "<command> Use <command> to open URL %s"; - "-nodoc", Arg.Clear Prefs.withdoc, + "-nodoc", Arg.Unit (fun () -> + prerr_endline "Warning: -nodoc option is deprecated. Use -with-doc no instead."; + Prefs.withdoc := false), " Deprecated: use -with-doc no instead"; "-with-doc", arg_bool Prefs.withdoc, "(yes|no) Compile the documentation or not"; @@ -335,18 +339,23 @@ let args_options = Arg.align [ "(yes|no) Use Geoproof binding or not"; "-byte-only", Arg.Set Prefs.byteonly, " Compiles only bytecode version of Coq"; - "-byteonly", Arg.Set Prefs.byteonly, - " Compiles only bytecode version of Coq"; - "-debug", Arg.Set Prefs.debug, - " Deprecated"; + "-byteonly", Arg.Unit (fun () -> + prerr_endline "Warning: -byteonly option is deprecated. Use -byte-only instead."; + Prefs.byteonly := true), + " Deprecated: use -byte-only instead"; + "-debug", Arg.Unit (fun () -> + prerr_endline "Warning: -debug option is deprecated. Coq is compiled in debug mode by default."; + Prefs.debug := true), + " Deprecated: Coq is compiled in debug mode by default"; "-nodebug", Arg.Clear Prefs.debug, " Do not add debugging information in the Coq executables"; "-profile", Arg.Set Prefs.profile, " Add profiling information in the Coq executables"; "-annotate", Arg.Set Prefs.annotate, " Dumps ml annotation files while compiling Coq"; - "-makecmd", Arg.String (fun _ -> printf "Warning: obsolete -makecmd option\n"), - "<command> Obsolete: name of GNU Make command"; + "-makecmd", Arg.String (fun _ -> + prerr_endline "Warning: -makecmd option is deprecated and doesn't have any effect."), + "<command> Deprecated"; "-native-compiler", arg_bool Prefs.nativecompiler, "(yes|no) Compilation to native code for conversion and normalization"; "-coqwebsite", Arg.Set_string Prefs.coqwebsite, diff --git a/dev/base_include b/dev/base_include index defea713d8..8ee1cceb23 100644 --- a/dev/base_include +++ b/dev/base_include @@ -58,8 +58,6 @@ (* Open main files *) -open API -open Grammar_API open Names open Term open Vars @@ -233,7 +231,7 @@ let pf_e gl s = let _ = Flags.in_debugger := false let _ = Flags.in_toplevel := true let _ = Constrextern.set_extern_reference - (fun loc _ r -> Libnames.Qualid (loc,Nametab.shortest_qualid_of_global Idset.empty r));; + (fun ?loc _ r -> Libnames.Qualid (loc,Nametab.shortest_qualid_of_global Idset.empty r));; open Coqloop let go = loop diff --git a/dev/ci/ci-basic-overlay.sh b/dev/ci/ci-basic-overlay.sh index 3adc319355..99ec43e412 100644 --- a/dev/ci/ci-basic-overlay.sh +++ b/dev/ci/ci-basic-overlay.sh @@ -13,8 +13,8 @@ ######################################################################## # UniMath ######################################################################## -: ${UniMath_CI_BRANCH:=coq_makefile2-fix} -: ${UniMath_CI_GITURL:=https://github.com/maximedenes/UniMath.git} +: ${UniMath_CI_BRANCH:=master} +: ${UniMath_CI_GITURL:=https://github.com/UniMath/UniMath.git} ######################################################################## # Unicoq + Metacoq @@ -28,11 +28,11 @@ ######################################################################## # Mathclasses + Corn ######################################################################## -: ${math_classes_CI_BRANCH:=v8.6} -: ${math_classes_CI_GITURL:=https://github.com/math-classes/math-classes.git} +: ${math_classes_CI_BRANCH:=external-bignums} +: ${math_classes_CI_GITURL:=https://github.com/letouzey/math-classes.git} -: ${Corn_CI_BRANCH:=v8.6} -: ${Corn_CI_GITURL:=https://github.com/c-corn/corn.git} +: ${Corn_CI_BRANCH:=external-bignums} +: ${Corn_CI_GITURL:=https://github.com/letouzey/corn.git} ######################################################################## # Iris @@ -73,14 +73,14 @@ ######################################################################## # CompCert ######################################################################## -: ${CompCert_CI_BRANCH:=master} -: ${CompCert_CI_GITURL:=https://github.com/AbsInt/CompCert.git} +: ${CompCert_CI_BRANCH:=less_init_plugins} +: ${CompCert_CI_GITURL:=https://github.com/letouzey/CompCert.git} ######################################################################## # VST ######################################################################## -: ${VST_CI_BRANCH:=master} -: ${VST_CI_GITURL:=https://github.com/PrincetonUniversity/VST.git} +: ${VST_CI_BRANCH:=less_init_plugins} +: ${VST_CI_GITURL:=https://github.com/letouzey/VST.git} ######################################################################## # fiat_parsers @@ -91,20 +91,8 @@ ######################################################################## # fiat_crypto ######################################################################## -: ${fiat_crypto_CI_BRANCH:=master} -: ${fiat_crypto_CI_GITURL:=https://github.com/mit-plv/fiat-crypto.git} - -######################################################################## -# bedrock_src -######################################################################## -: ${bedrock_src_CI_BRANCH:=trunk__API} -: ${bedrock_src_CI_GITURL:=https://github.com/matejkosik/bedrock.git} - -######################################################################## -# bedrock_facade -######################################################################## -: ${bedrock_facade_CI_BRANCH:=trunk__API} -: ${bedrock_facade_CI_GITURL:=https://github.com/matejkosik/bedrock.git} +: ${fiat_crypto_CI_BRANCH:=less_init_plugins} +: ${fiat_crypto_CI_GITURL:=https://github.com/letouzey/fiat-crypto.git} ######################################################################## # formal-topology @@ -133,3 +121,9 @@ ######################################################################## : ${tlc_CI_BRANCH:=master} : ${tlc_CI_GITURL:=https://gforge.inria.fr/git/tlc/tlc.git} + +######################################################################## +# Bignums +######################################################################## +: ${bignums_CI_BRANCH:=master} +: ${bignums_CI_GITURL:=https://github.com/coq/bignums.git} diff --git a/dev/ci/ci-bedrock-facade.sh b/dev/ci/ci-bedrock-facade.sh deleted file mode 100755 index 95cfa3073f..0000000000 --- a/dev/ci/ci-bedrock-facade.sh +++ /dev/null @@ -1,10 +0,0 @@ -#!/usr/bin/env bash - -ci_dir="$(dirname "$0")" -source ${ci_dir}/ci-common.sh - -bedrock_facade_CI_DIR=${CI_BUILD_DIR}/bedrock-facade - -git_checkout ${bedrock_facade_CI_BRANCH} ${bedrock_facade_CI_GITURL} ${bedrock_facade_CI_DIR} - -( cd ${bedrock_facade_CI_DIR} && make -j ${NJOBS} facade ) diff --git a/dev/ci/ci-bedrock-src.sh b/dev/ci/ci-bedrock-src.sh deleted file mode 100755 index 532611d4b3..0000000000 --- a/dev/ci/ci-bedrock-src.sh +++ /dev/null @@ -1,10 +0,0 @@ -#!/usr/bin/env bash - -ci_dir="$(dirname "$0")" -source ${ci_dir}/ci-common.sh - -bedrock_src_CI_DIR=${CI_BUILD_DIR}/bedrock-src - -git_checkout ${bedrock_src_CI_BRANCH} ${bedrock_src_CI_GITURL} ${bedrock_src_CI_DIR} - -( cd ${bedrock_src_CI_DIR} && make -j ${NJOBS} src ) diff --git a/dev/ci/ci-bignums.sh b/dev/ci/ci-bignums.sh new file mode 100755 index 0000000000..ff5935d4c7 --- /dev/null +++ b/dev/ci/ci-bignums.sh @@ -0,0 +1,16 @@ +#!/usr/bin/env bash + +ci_dir="$(dirname "$0")" + +# This script could be included inside other ones +# Let's avoid to source ci-common twice in this case +if [ -z "${CI_BUILD_DIR}"]; +then + source ${ci_dir}/ci-common.sh +fi + +bignums_CI_DIR=${CI_BUILD_DIR}/Bignums + +git_checkout ${bignums_CI_BRANCH} ${bignums_CI_GITURL} ${bignums_CI_DIR} + +( cd ${bignums_CI_DIR} && make -j ${NJOBS} && make install) diff --git a/dev/ci/ci-color.sh b/dev/ci/ci-color.sh index 3f0716511d..a0a4e0749d 100755 --- a/dev/ci/ci-color.sh +++ b/dev/ci/ci-color.sh @@ -5,6 +5,31 @@ source ${ci_dir}/ci-common.sh Color_CI_DIR=${CI_BUILD_DIR}/color +# Setup Bignums + +source ${ci_dir}/ci-bignums.sh + +# Compiles CoLoR + svn checkout ${Color_CI_SVNURL} ${Color_CI_DIR} +sed -i -e "s/From Coq Require Import BigN/From Bignums Require Import BigN/" ${Color_CI_DIR}/Util/*/*.v +sed -i -e "s/From Coq Require Export BigN/From Bignums Require Export BigN/" ${Color_CI_DIR}/Util/*/*.v +sed -i -e "s/From Coq Require Import BigZ/From Bignums Require Import BigZ/" ${Color_CI_DIR}/Util/*/*.v +sed -i -e "s/From Coq Require Export BigZ/From Bignums Require Export BigZ/" ${Color_CI_DIR}/Util/*/*.v + +# Adapt to PR #220 (FunInd not loaded in Prelude anymore) +sed -i -e "15i From Coq Require Import FunInd." ${Color_CI_DIR}/Coccinelle/basis/ordered_set.v +sed -i -e "8i From Coq Require Import FunInd." ${Color_CI_DIR}/Coccinelle/examples/cime_trace/equational_extension.v +sed -i -e "6i From Coq Require Import FunInd." ${Color_CI_DIR}/Coccinelle/examples/cime_trace/more_list_extention.v +sed -i -e "6i From Coq Require Import FunInd." ${Color_CI_DIR}/Coccinelle/examples/cime_trace/ring_extention.v +sed -i -e "27i From Coq Require Import FunInd." ${Color_CI_DIR}/Coccinelle/list_extensions/dickson.v +sed -i -e "26i From Coq Require Import FunInd." ${Color_CI_DIR}/Coccinelle/list_extensions/list_permut.v +sed -i -e "23i From Coq Require Import FunInd." ${Color_CI_DIR}/Coccinelle/list_extensions/list_set.v +sed -i -e "25i From Coq Require Import FunInd." ${Color_CI_DIR}/Coccinelle/list_extensions/list_sort.v +sed -i -e "21i From Coq Require Import FunInd." ${Color_CI_DIR}/Coccinelle/list_extensions/more_list.v +sed -i -e "21i From Coq Require Import FunInd." ${Color_CI_DIR}/Util/List/ListUtil.v +sed -i -e "17i From Coq Require Import FunInd." ${Color_CI_DIR}/Util/Multiset/MultisetOrder.v +sed -i -e "13i From Coq Require Import FunInd." ${Color_CI_DIR}/Util/Set/SetUtil.v + ( cd ${Color_CI_DIR} && make -j ${NJOBS} ) diff --git a/dev/ci/ci-formal-topology.sh b/dev/ci/ci-formal-topology.sh index ecb36349fb..64b78c0396 100755 --- a/dev/ci/ci-formal-topology.sh +++ b/dev/ci/ci-formal-topology.sh @@ -9,6 +9,10 @@ Corn_CI_DIR=${CI_BUILD_DIR}/corn formal_topology_CI_DIR=${CI_BUILD_DIR}/formal-topology +# Setup Bignums + +source ${ci_dir}/ci-bignums.sh + # Setup Math-Classes git_checkout ${math_classes_CI_BRANCH} ${math_classes_CI_GITURL} ${math_classes_CI_DIR} diff --git a/dev/ci/ci-math-classes.sh b/dev/ci/ci-math-classes.sh index beb75773b7..46581c6381 100755 --- a/dev/ci/ci-math-classes.sh +++ b/dev/ci/ci-math-classes.sh @@ -7,6 +7,10 @@ math_classes_CI_DIR=${CI_BUILD_DIR}/math-classes Corn_CI_DIR=${CI_BUILD_DIR}/corn +# Setup Bignums + +source ${ci_dir}/ci-bignums.sh + # Setup Math-Classes git_checkout ${math_classes_CI_BRANCH} ${math_classes_CI_GITURL} ${math_classes_CI_DIR} diff --git a/dev/ci/ci-sf.sh b/dev/ci/ci-sf.sh index 7d23ccad97..23ef41d2dd 100755 --- a/dev/ci/ci-sf.sh +++ b/dev/ci/ci-sf.sh @@ -7,6 +7,8 @@ source ${ci_dir}/ci-common.sh wget ${sf_CI_TARURL} tar xvfz sf.tgz +sed -i.bak '15i From Coq Require Extraction.' sf/Extraction.v + ( cd sf && sed -i.bak 's/(K,N)/((K,N))/' LibTactics.v && make clean && make -j ${NJOBS} ) diff --git a/dev/ci/ci-user-overlay.sh b/dev/ci/ci-user-overlay.sh index 0edaf07efc..b242ce3bd9 100644 --- a/dev/ci/ci-user-overlay.sh +++ b/dev/ci/ci-user-overlay.sh @@ -33,10 +33,22 @@ fi echo "DEBUG: ci-user-overlay.sh 0" if [ $TRAVIS_PULL_REQUEST = "707" ] || [ $TRAVIS_BRANCH == "trunk__API__coq_makefile" ]; then echo "DEBUG: ci-user-overlay.sh 1" - bedrock_src_CI_BRANCH=trunk__API - bedrock_src_CI_GITURL=https://github.com/matejkosik/bedrock.git - bedrock_facade_CI_BRANCH=trunk__API - bedrock_facade_CI_GITURL=https://github.com/matejkosik/bedrock.git fiat_parsers_CI_BRANCH=trunk__API fiat_parsers_CI_GITURL=https://github.com/matejkosik/fiat.git fi + +if [ $TRAVIS_PULL_REQUEST == "498" ] || [ $TRAVIS_BRANCH == "outsource-bignums" ]; then + math_classes_CI_BRANCH=external-bignums + math_classes_CI_GITURL=https://github.com/letouzey/math-classes.git + Corn_CI_BRANCH=external-bignums + Corn_CI_GITURL=https://github.com/letouzey/corn.git +fi + +if [ $TRAVIS_PULL_REQUEST == "220" ] || [ $TRAVIS_BRANCH == "less_init_plugins" ]; then + CompCert_CI_BRANCH=less_init_plugins + CompCert_CI_GITURL=https://github.com/letouzey/CompCert.git + VST_CI_BRANCH=less_init_plugins + VST_CI_GITURL=https://github.com/letouzey/VST.git + fiat_crypto_CI_BRANCH=less_init_plugins + fiat_crypto_CI_GITURL=https://github.com/letouzey/fiat-crypto.git +fi diff --git a/dev/core.dbg b/dev/core.dbg index 6acdd01528..71d06cdb0a 100644 --- a/dev/core.dbg +++ b/dev/core.dbg @@ -17,4 +17,6 @@ load_printer vernac.cma load_printer stm.cma load_printer toplevel.cma load_printer highparsing.cma +load_printer intf.cma +load_printer API.cma load_printer ltac_plugin.cmo diff --git a/dev/doc/changes.txt b/dev/doc/changes.txt index 631b5f5aaf..0728608f31 100644 --- a/dev/doc/changes.txt +++ b/dev/doc/changes.txt @@ -154,6 +154,9 @@ In Coqlib / reference location: - The tclWEAK_PROGRESS and tclNOTSAMEGOAL tacticals were removed. Their usecase was very specific. Use tclPROGRESS instead. +- The unsafe flag of the Refine.refine function and its variants has been + renamed and dualized into typecheck and has been made mandatory. + ** Ltac API ** Many Ltac specific API has been moved in its own ltac/ folder. Amongst other diff --git a/dev/doc/proof-engine.md b/dev/doc/proof-engine.md index db69b08a20..8f96ac223f 100644 --- a/dev/doc/proof-engine.md +++ b/dev/doc/proof-engine.md @@ -42,14 +42,13 @@ goal holes thanks to the `Refine` module, and in particular to the `Refine.refine` primitive. ```ocaml -val refine : ?unsafe:bool -> Constr.t Sigma.run -> unit tactic -(** In [refine ?unsafe t], [t] is a term with holes under some +val refine : typecheck:bool -> Constr.t Sigma.run -> unit tactic +(** In [refine typecheck t], [t] is a term with holes under some [evar_map] context. The term [t] is used as a partial solution for the current goal (refine is a goal-dependent tactic), the new holes created by [t] become the new subgoals. Exceptions raised during the interpretation of [t] are caught and result in - tactic failures. If [unsafe] is [false] (default is [true]) [t] is - type-checked beforehand. *) + tactic failures. If [typecheck] is [true] [t] is type-checked beforehand. *) ``` In a first approximation, we can think of `'a Sigma.run` as diff --git a/dev/doc/setup.txt b/dev/doc/setup.txt index 1b016a4e26..0c6d3ee80d 100644 --- a/dev/doc/setup.txt +++ b/dev/doc/setup.txt @@ -12,7 +12,7 @@ How to compile Coq Getting build dependencies: - sudo apt-get install make opam git mercurial darcs + sudo apt-get install make opam git opam init --comp 4.02.3 # Then follow the advice displayed at the end as how to update your ~/.bashrc and ~/.ocamlinit files. @@ -41,7 +41,7 @@ Building coqtop: cd ~/git/coq git checkout trunk make distclean - ./configure -annotate -with-doc no -local -debug -usecamlp5 + ./configure -annotate -local make clean make -j4 coqide printers @@ -49,8 +49,6 @@ The "-annotate" option is essential when one wants to use Merlin. The "-local" option is useful if one wants to run the coqtop and coqide binaries without running make install -The "-debug" option is essential if one wants to use ocamldebug with the coqtop binary. - Then check if - bin/coqtop - bin/coqide @@ -60,7 +58,7 @@ behave as expected. A note about rlwrap ------------------- -Running "coqtop" under "rlwrap" is possible, but there is a catch. If you try: +Running "coqtop" under "rlwrap" is possible, but (on Debian) there is a catch. If you try: cd ~/git/coq rlwrap bin/coqtop diff --git a/dev/include b/dev/include index 0f43f00729..31ae5da71a 100644 --- a/dev/include +++ b/dev/include @@ -41,6 +41,8 @@ #install_printer (* univ context *) ppuniverse_context;; #install_printer (* univ context future *) ppuniverse_context_future;; #install_printer (* univ context set *) ppuniverse_context_set;; +#install_printer (* cumulativity info *) ppcumulativity_info;; +#install_printer (* abstract cumulativity info *) ppabstract_cumulativity_info;; #install_printer (* univ set *) ppuniverse_set;; #install_printer (* univ instance *) ppuniverse_instance;; #install_printer (* univ subst *) ppuniverse_subst;; diff --git a/dev/ocamldebug-coq.run b/dev/ocamldebug-coq.run index 3850c05fd9..f4799f7b2c 100644 --- a/dev/ocamldebug-coq.run +++ b/dev/ocamldebug-coq.run @@ -23,6 +23,7 @@ exec $OCAMLDEBUG \ -I $COQTOP/pretyping -I $COQTOP/parsing -I $COQTOP/vernac \ -I $COQTOP/interp -I $COQTOP/proofs -I $COQTOP/tactics -I $COQTOP/stm \ -I $COQTOP/toplevel -I $COQTOP/dev -I $COQTOP/config -I $COQTOP/ltac \ + -I $COQTOP/API \ -I $COQTOP/plugins/cc -I $COQTOP/plugins/dp \ -I $COQTOP/plugins/extraction -I $COQTOP/plugins/field \ -I $COQTOP/plugins/firstorder -I $COQTOP/plugins/fourier \ diff --git a/dev/top_printers.ml b/dev/top_printers.ml index 6ae5125f6d..ff575e432c 100644 --- a/dev/top_printers.ml +++ b/dev/top_printers.ml @@ -8,7 +8,6 @@ (* Printers for the ocaml toplevel. *) -open API open Util open Pp open Names @@ -215,6 +214,7 @@ let ppuniverseconstraints c = pp (Universes.Constraints.pr c) let ppuniverse_context_future c = let ctx = Future.force c in ppuniverse_context ctx +let ppcumulativity_info c = pp (Univ.pr_cumulativity_info Univ.Level.pr c) let ppuniverses u = pp (UGraph.pr_universes Level.pr u) let ppnamedcontextval e = pp (pr_named_context (Global.env ()) Evd.empty (named_context_of_val e)) diff --git a/dev/vm_printers.ml b/dev/vm_printers.ml index be6b914b6b..afa94a63e0 100644 --- a/dev/vm_printers.ml +++ b/dev/vm_printers.ml @@ -1,4 +1,3 @@ -open API open Format open Term open Names diff --git a/doc/refman/Extraction.tex b/doc/refman/Extraction.tex index 01dbcfb1cb..fa3d61b1cd 100644 --- a/doc/refman/Extraction.tex +++ b/doc/refman/Extraction.tex @@ -19,6 +19,12 @@ be used (abusively) to refer to any of the three. %% the one in previous versions of \Coq: there is no more %% an explicit toplevel for the language (formerly called \textsc{Fml}). +Before using any of the commands or options described in this chapter, +the extraction framework should first be loaded explicitly +via {\tt Require Extraction}. Note that in earlier versions of Coq, these +commands and options were directly available without any preliminary +{\tt Require}. + \asection{Generating ML code} \comindex{Extraction} \comindex{Recursive Extraction} @@ -501,6 +507,7 @@ We can now extract this program to \ocaml: Reset Initial. \end{coq_eval} \begin{coq_example} +Require Extraction. Require Import Euclid Wf_nat. Extraction Inline gt_wf_rec lt_wf_rec induction_ltof2. Recursive Extraction eucl_dev. diff --git a/doc/refman/RefMan-cic.tex b/doc/refman/RefMan-cic.tex index fdd2725810..96fb1eb752 100644 --- a/doc/refman/RefMan-cic.tex +++ b/doc/refman/RefMan-cic.tex @@ -461,6 +461,13 @@ recursively convertible to $u'_1$, or, symmetrically, $u_2$ is $\lb x:T\mto u'_2$ and $u_1\,x$ is recursively convertible to $u'_2$. We then write $\WTEGCONV{t_1}{t_2}$. +Apart from this we consider two instances of polymorphic and cumulative (see Chapter~\ref{Universes-full}) inductive types (see below) +convertible $\WTEGCONV{t\ w_1 \dots w_m}{t\ w_1' \dots w_m'}$ if we have subtypings (see below) in both directions, i.e., +$\WTEGLECONV{t\ w_1 \dots w_m}{t\ w_1' \dots w_m'}$ and $\WTEGLECONV{t\ w_1' \dots w_m'}{t\ w_1 \dots w_m}$. +Furthermore, we consider $\WTEGCONV{c\ v_1 \dots v_m}{c'\ v_1' \dots v_m'}$ convertible if $\WTEGCONV{v_i}{v_i'}$ +and we have that $c$ and $c'$ are the same constructors of different instances the same inductive types (differing only in universe levels) +such that $\WTEG{c\ v_1 \dots v_m}{t\ w_1 \dots w_m}$ and $\WTEG{c'\ v_1' \dots v_m'}{t'\ w_1' \dots w_m'}$ and we have $\WTEGCONV{t\ w_1 \dots w_m}{t\ w_1' \dots w_m'}$. + The convertibility relation allows introducing a new typing rule which says that two convertible well-formed types have the same inhabitants. @@ -480,6 +487,17 @@ convertibility into a {\em subtyping} relation inductively defined by: \item $\WTEGLECONV{\Prop}{\Set}$, hence, by transitivity, $\WTEGLECONV{\Prop}{\Type(i)}$, for any $i$ \item if $\WTEGCONV{T}{U}$ and $\WTELECONV{\Gamma::(x:T)}{T'}{U'}$ then $\WTEGLECONV{\forall~x:T, T'}{\forall~x:U, U'}$. +\item if $\Ind{}{p}{\Gamma_I}{\Gamma_C}$ is a universe polymorphic and cumulative (see Chapter~\ref{Universes-full}) + inductive type (see below) and $(t : \forall\Gamma_P,\forall\Gamma_{\mathit{Arr}(t)}, \Sort)\in\Gamma_I$ + and $(t' : \forall\Gamma_P',\forall\Gamma_{\mathit{Arr}(t)}', \Sort')\in\Gamma_I$ + are two different instances of \emph{the same} inductive type (differing only in universe levels) with constructors + \[[c_1: \forall\Gamma_P,\forall T_{1,1} \dots T_{1,n_1},t\ v_{1,1} \dots v_{1,m}; \dots; c_k: \forall\Gamma_P,\forall T_{k, 1} \dots T_{k,n_k},t\ v_{n,1}\dots v_{n,m}]\] + and + \[[c_1: \forall\Gamma_P',\forall T_{1,1}' \dots T_{1,n_1}',t'\ v_{1,1}' \dots v_{1,m}'; \dots; c_k: \forall\Gamma_P',\forall T_{k, 1}' \dots T_{k,n_k}',t\ v_{n,1}'\dots v_{n,m}']\] + respectively then $\WTEGLECONV{t\ w_1 \dots w_m}{t\ w_1' \dots w_m'}$ (notice that $t$ and $t'$ are both fully applied, i.e., they have a sort as a type) + if $\WTEGCONV{w_i}{w_i'}$ for $1 \le i \le m$ and we have + \[ \WTEGLECONV{T_{i,j}}{T_{i,j}'} \text{ and } \WTEGLECONV{A_i}{A_i'}\] + where $\Gamma_{\mathit{Arr}(t)} = [a_1 : A_1; a_1 : A_l]$ and $\Gamma_{\mathit{Arr}(t)} = [a_1 : A_1'; a_1 : A_l']$. \end{enumerate} The conversion rule up to subtyping is now exactly: @@ -530,8 +548,12 @@ Formally, we can represent any {\em inductive definition\index{definition!induct These inductive definitions, together with global assumptions and global definitions, then form the global environment. % Additionally, for any $p$ there always exists $\Gamma_P=[a_1:A_1;\dots;a_p:A_p]$ -such that each $(t:T)\in\Gamma_I\cup\Gamma_C$ can be written as: +such that each $T$ in $(t:T)\in\Gamma_I\cup\Gamma_C$ can be written as: $\forall\Gamma_P, T^\prime$ where $\Gamma_P$ is called the {\em context of parameters\index{context of parameters}}. +Furthermore, we must have that each $T$ in $(t:T)\in\Gamma_I$ can be written as: +$\forall\Gamma_P,\forall\Gamma_{\mathit{Arr}(t)}, \Sort$ where $\Gamma_{\mathit{Arr}(t)}$ is called the +{\em Arity} of the inductive type\index{arity of inductive type} $t$ and +$\Sort$ is called the sort of the inductive type $t$. \paragraph{Examples} diff --git a/doc/refman/RefMan-ext.tex b/doc/refman/RefMan-ext.tex index 6dd0ddf81d..939fc87a6e 100644 --- a/doc/refman/RefMan-ext.tex +++ b/doc/refman/RefMan-ext.tex @@ -721,18 +721,20 @@ a given type. See Section~\ref{Show}. \section{Advanced recursive functions} -The \emph{experimental} command +The following \emph{experimental} command is available +when the {\tt FunInd} library has been loaded via {\tt Require Import FunInd}: \begin{center} \texttt{Function {\ident} {\binder$_1$}\ldots{\binder$_n$} \{decrease\_annot\} : type$_0$ := \term$_0$} \comindex{Function} \label{Function} \end{center} -can be seen as a generalization of {\tt Fixpoint}. It is actually a -wrapper for several ways of defining a function \emph{and other useful +This command can be seen as a generalization of {\tt Fixpoint}. It is actually +a wrapper for several ways of defining a function \emph{and other useful related objects}, namely: an induction principle that reflects the recursive structure of the function (see \ref{FunInduction}), and its -fixpoint equality. The meaning of this +fixpoint equality. + The meaning of this declaration is to define a function {\it ident}, similarly to {\tt Fixpoint}. Like in {\tt Fixpoint}, the decreasing argument must be given (unless the function is not recursive), but it must not diff --git a/doc/refman/RefMan-pro.tex b/doc/refman/RefMan-pro.tex index 0760d716e3..b66659dc8c 100644 --- a/doc/refman/RefMan-pro.tex +++ b/doc/refman/RefMan-pro.tex @@ -427,22 +427,6 @@ This command displays the current goals. This tactics script may contain some holes (subgoals not yet proved). They are printed under the form \verb!<Your Tactic Text here>!. -%% \item {\tt Show Tree.}\comindex{Show Tree}\\ -%% This command can be seen as a more structured way of -%% displaying the state of the proof than that -%% provided by {\tt Show Script}. Instead of just giving -%% the list of tactics that have been applied, it -%% shows the derivation tree constructed by then. -%% Each node of the tree contains the conclusion -%% of the corresponding sub-derivation (i.e. a -%% goal with its corresponding local context) and -%% the tactic that has generated all the -%% sub-derivations. The leaves of this tree are -%% the goals which still remain to be proved. - -%\item {\tt Show Node}\comindex{Show Node}\\ -% Not yet documented - \item {\tt Show Proof.}\comindex{Show Proof}\\ It displays the proof term generated by the tactics that have been applied. diff --git a/doc/refman/RefMan-sch.tex b/doc/refman/RefMan-sch.tex index 53aa6b86ab..d3719bed46 100644 --- a/doc/refman/RefMan-sch.tex +++ b/doc/refman/RefMan-sch.tex @@ -196,8 +196,10 @@ Check tree_forest_mutind. The {\tt Functional Scheme} command is a high-level experimental tool for generating automatically induction principles -corresponding to (possibly mutually recursive) functions. Its -syntax follows the schema: +corresponding to (possibly mutually recursive) functions. +First, it must be made available via {\tt Require Import FunInd}. + Its +syntax then follows the schema: \begin{quote} {\tt Functional Scheme {\ident$_1$} := Induction for \ident'$_1$ Sort {\sort$_1$} \\ with\\ @@ -319,6 +321,7 @@ of a tree or a forest. Note that we use \texttt{Function} which generally produces better principles. \begin{coq_example*} +Require Import FunInd. Function tree_size (t:tree) : nat := match t with | node A f => S (forest_size f) diff --git a/doc/refman/RefMan-tac.tex b/doc/refman/RefMan-tac.tex index 673071c58a..be75dc9d56 100644 --- a/doc/refman/RefMan-tac.tex +++ b/doc/refman/RefMan-tac.tex @@ -2140,13 +2140,15 @@ The tactic \texttt{functional induction} performs case analysis and induction following the definition of a function. It makes use of a principle generated by \texttt{Function} (see Section~\ref{Function}) or \texttt{Functional Scheme} -(see Section~\ref{FunScheme}). +(see Section~\ref{FunScheme}). Note that this tactic is only available +after a {\tt Require Import FunInd}. \begin{coq_eval} Reset Initial. Import Nat. \end{coq_eval} \begin{coq_example} +Require Import FunInd. Functional Scheme minus_ind := Induction for minus Sort Prop. Check minus_ind. Lemma le_minus (n m:nat) : n - m <= n. @@ -4824,6 +4826,7 @@ that performs inversion on hypothesis {\ident} of the form \texttt{\qualid\ \term$_1$\dots\term$_n$\ = \term} or \texttt{\term\ = \qualid\ \term$_1$\dots\term$_n$} where \qualid\ must have been defined using \texttt{Function} (see Section~\ref{Function}). +Note that this tactic is only available after a {\tt Require Import FunInd}. \begin{ErrMsgs} \item \errindex{Hypothesis {\ident} must contain at least one Function} diff --git a/doc/refman/Universes.tex b/doc/refman/Universes.tex index 36518e6fae..2bb1301c79 100644 --- a/doc/refman/Universes.tex +++ b/doc/refman/Universes.tex @@ -131,6 +131,52 @@ producing global universe constraints, one can use the polymorphically, not at a single instance. \end{itemize} +\asection{{\tt Cumulative, NonCumulative}} +\comindex{Cumulative} +\comindex{NonCumulative} +\optindex{Inductive Cumulativity} + +Inductive types, coinductive types, variants and records can be +declared cumulative using the \texttt{Cumulative}. Alternatively, +there is an option \texttt{Set Inductive Cumulativity} which when set, +makes all subsequent inductive definitions cumulative. Consider the examples below. +\begin{coq_example*} +Polymorphic Cumulative Inductive list {A : Type} := +| nil : list +| cons : A -> list -> list. +\end{coq_example*} +\begin{coq_example} +Print list. +\end{coq_example} +When printing \texttt{list}, the part of the output of the form +\texttt{$\mathtt{\sim}$@\{i\} <= $\mathtt{\sim}$@\{j\} iff } +indicates the universe constraints in order to have the subtyping +$\WTEGLECONV{\mathtt{list@\{i\}} A}{\mathtt{list@\{j\}} B}$ +(for fully applied instances of \texttt{list}) whenever $\WTEGCONV{A}{B}$. +In the case of \texttt{list} there is no constraint! +This also means that any two instances of \texttt{list} are convertible: +$\WTEGCONV{\mathtt{list@\{i\}} A}{\mathtt{list@\{j\}} B}$ whenever $\WTEGCONV{A}{B}$ and +furthermore their corresponding (when fully applied to convertible arguments) constructors. +See Chapter~\ref{Cic} for more details on convertibility and subtyping. +Also notice the subtyping constraints for the \emph{non-cumulative} version of list: +\begin{coq_example*} +Polymorphic NonCumulative Inductive list' {A : Type} := +| nil' : list' +| cons' : A -> list' -> list'. +\end{coq_example*} +\begin{coq_example} +Print list'. +\end{coq_example} +The following is an example of a record with non-trivial subtyping relation: +\begin{coq_example*} +Polymorphic Cumulative Record packType := {pk : Type}. +\end{coq_example*} +\begin{coq_example} +Print packType. +\end{coq_example} +Notice that as expected, \texttt{packType@\{i\}} and \texttt{packType@\{j\}} are convertible if and only if \texttt{i $=$ j}. + + \asection{Global and local universes} Each universe is declared in a global or local environment before it can diff --git a/doc/stdlib/index-list.html.template b/doc/stdlib/index-list.html.template index aeb0de48a3..48f82f2d92 100644 --- a/doc/stdlib/index-list.html.template +++ b/doc/stdlib/index-list.html.template @@ -224,7 +224,6 @@ through the <tt>Require Import</tt> command.</p> <dd> theories/Numbers/BinNums.v theories/Numbers/NumPrelude.v - theories/Numbers/BigNumPrelude.v theories/Numbers/NaryFunctions.v </dd> @@ -256,16 +255,7 @@ through the <tt>Require Import</tt> command.</p> <dd> theories/Numbers/Cyclic/Abstract/CyclicAxioms.v theories/Numbers/Cyclic/Abstract/NZCyclic.v - theories/Numbers/Cyclic/DoubleCyclic/DoubleAdd.v - theories/Numbers/Cyclic/DoubleCyclic/DoubleBase.v - theories/Numbers/Cyclic/DoubleCyclic/DoubleCyclic.v - theories/Numbers/Cyclic/DoubleCyclic/DoubleDiv.v - theories/Numbers/Cyclic/DoubleCyclic/DoubleDivn1.v - theories/Numbers/Cyclic/DoubleCyclic/DoubleLift.v - theories/Numbers/Cyclic/DoubleCyclic/DoubleMul.v - theories/Numbers/Cyclic/DoubleCyclic/DoubleSqrt.v - theories/Numbers/Cyclic/DoubleCyclic/DoubleSub.v - theories/Numbers/Cyclic/DoubleCyclic/DoubleType.v + theories/Numbers/Cyclic/Abstract/DoubleType.v theories/Numbers/Cyclic/Int31/Cyclic31.v theories/Numbers/Cyclic/Int31/Ring31.v theories/Numbers/Cyclic/Int31/Int31.v @@ -298,12 +288,6 @@ through the <tt>Require Import</tt> command.</p> theories/Numbers/Natural/Abstract/NProperties.v theories/Numbers/Natural/Binary/NBinary.v theories/Numbers/Natural/Peano/NPeano.v - theories/Numbers/Natural/SpecViaZ/NSig.v - theories/Numbers/Natural/SpecViaZ/NSigNAxioms.v - theories/Numbers/Natural/BigN/BigN.v - theories/Numbers/Natural/BigN/Nbasic.v - theories/Numbers/Natural/BigN/NMake.v - theories/Numbers/Natural/BigN/NMake_gen.v </dd> <dt> <b> Integer</b>: @@ -331,19 +315,6 @@ through the <tt>Require Import</tt> command.</p> theories/Numbers/Integer/Abstract/ZDivTrunc.v theories/Numbers/Integer/Binary/ZBinary.v theories/Numbers/Integer/NatPairs/ZNatPairs.v - theories/Numbers/Integer/SpecViaZ/ZSig.v - theories/Numbers/Integer/SpecViaZ/ZSigZAxioms.v - theories/Numbers/Integer/BigZ/BigZ.v - theories/Numbers/Integer/BigZ/ZMake.v - </dd> - - <dt><b> Rational</b>: - Abstract and 31-bits-words-based rational arithmetic - </dt> - <dd> - theories/Numbers/Rational/SpecViaQ/QSig.v - theories/Numbers/Rational/BigQ/BigQ.v - theories/Numbers/Rational/BigQ/QMake.v </dd> </dl> </dd> @@ -618,7 +589,6 @@ through the <tt>Require Import</tt> command.</p> </dt> <dd> theories/Compat/AdmitAxiom.v - theories/Compat/Coq84.v theories/Compat/Coq85.v theories/Compat/Coq86.v </dd> diff --git a/engine/namegen.ml b/engine/namegen.ml index 5bd62273c8..783085654e 100644 --- a/engine/namegen.ml +++ b/engine/namegen.ml @@ -412,13 +412,12 @@ let rename_bound_vars_as_displayed sigma avoid env c = let h_based_elimination_names = ref false -let use_h_based_elimination_names () = - !h_based_elimination_names && Flags.version_strictly_greater Flags.V8_4 +let use_h_based_elimination_names () = !h_based_elimination_names open Goptions let _ = declare_bool_option - { optdepr = false; + { optdepr = true; (* remove in 8.8 *) optname = "use of \"H\"-based proposition names in elimination tactics"; optkey = ["Standard";"Proposition";"Elimination";"Names"]; optread = (fun () -> !h_based_elimination_names); diff --git a/engine/termops.ml b/engine/termops.ml index 92016d4af4..3eef71b2d0 100644 --- a/engine/termops.ml +++ b/engine/termops.ml @@ -1173,6 +1173,9 @@ let compare_constr_univ sigma f cv_pb t1 t2 = Sort s1, Sort s2 -> base_sort_cmp cv_pb (ESorts.kind sigma s1) (ESorts.kind sigma s2) | Prod (_,t1,c1), Prod (_,t2,c2) -> f Reduction.CONV t1 t2 && f cv_pb c1 c2 + | Const (c, u), Const (c', u') -> Constant.equal c c' + | Ind (i, _), Ind (i', _) -> eq_ind i i' + | Construct (i, _), Construct (i', _) -> eq_constructor i i' | _ -> EConstr.compare_constr sigma (fun t1 t2 -> f Reduction.CONV t1 t2) t1 t2 let constr_cmp sigma cv_pb t1 t2 = diff --git a/engine/uState.ml b/engine/uState.ml index acef901432..0973ca457f 100644 --- a/engine/uState.ml +++ b/engine/uState.ml @@ -284,7 +284,7 @@ let universe_context ?names ctx = in map, ctx let restrict ctx vars = - let uctx' = Universes.restrict_universe_context ctx.uctx_local vars in + let uctx' = Univops.restrict_universe_context ctx.uctx_local vars in { ctx with uctx_local = uctx' } type rigid = diff --git a/engine/universes.ml b/engine/universes.ml index f201081862..bd4d75930c 100644 --- a/engine/universes.ml +++ b/engine/universes.ml @@ -283,11 +283,11 @@ let new_Type_sort dp = Type (new_univ dp) let fresh_universe_instance ctx = Instance.subst_fn (fun _ -> new_univ_level (Global.current_dirpath ())) - (UContext.instance ctx) + (AUContext.instance ctx) let fresh_instance_from_context ctx = let inst = fresh_universe_instance ctx in - let constraints = instantiate_univ_constraints inst ctx in + let constraints = UContext.constraints (subst_instance_context inst ctx) in inst, constraints let fresh_instance ctx = @@ -296,13 +296,13 @@ let fresh_instance ctx = Instance.subst_fn (fun v -> let u = new_univ_level (Global.current_dirpath ()) in ctx' := LSet.add u !ctx'; u) - (UContext.instance ctx) + (AUContext.instance ctx) in !ctx', inst let existing_instance ctx inst = let () = let a1 = Instance.to_array inst - and a2 = Instance.to_array (UContext.instance ctx) in + and a2 = Instance.to_array (AUContext.instance ctx) in let len1 = Array.length a1 and len2 = Array.length a2 in if not (len1 == len2) then CErrors.user_err ~hdr:"Universes" @@ -317,59 +317,75 @@ let fresh_instance_from ctx inst = | Some inst -> existing_instance ctx inst | None -> fresh_instance ctx in - let constraints = instantiate_univ_constraints inst ctx in + let constraints = UContext.constraints (subst_instance_context inst ctx) in inst, (ctx', constraints) let unsafe_instance_from ctx = - (Univ.UContext.instance ctx, ctx) + (Univ.AUContext.instance ctx, Univ.instantiate_univ_context ctx) (** Fresh universe polymorphic construction *) let fresh_constant_instance env c inst = let cb = lookup_constant c env in - if cb.Declarations.const_polymorphic then - let inst, ctx = - fresh_instance_from - (Declareops.universes_of_constant (Environ.opaque_tables env) cb) inst - in - ((c, inst), ctx) - else ((c,Instance.empty), ContextSet.empty) + match cb.Declarations.const_universes with + | Declarations.Monomorphic_const _ -> ((c,Instance.empty), ContextSet.empty) + | Declarations.Polymorphic_const auctx -> + let inst, ctx = + fresh_instance_from auctx inst + in + ((c, inst), ctx) let fresh_inductive_instance env ind inst = let mib, mip = Inductive.lookup_mind_specif env ind in - if mib.Declarations.mind_polymorphic then - let inst, ctx = fresh_instance_from mib.Declarations.mind_universes inst in - ((ind,inst), ctx) - else ((ind,Instance.empty), ContextSet.empty) + match mib.Declarations.mind_universes with + | Declarations.Monomorphic_ind _ -> + ((ind,Instance.empty), ContextSet.empty) + | Declarations.Polymorphic_ind uactx -> + let inst, ctx = (fresh_instance_from uactx) inst in + ((ind,inst), ctx) + | Declarations.Cumulative_ind acumi -> + let inst, ctx = + fresh_instance_from (Univ.ACumulativityInfo.univ_context acumi) inst + in ((ind,inst), ctx) let fresh_constructor_instance env (ind,i) inst = let mib, mip = Inductive.lookup_mind_specif env ind in - if mib.Declarations.mind_polymorphic then - let inst, ctx = fresh_instance_from mib.Declarations.mind_universes inst in + match mib.Declarations.mind_universes with + | Declarations.Monomorphic_ind _ -> (((ind,i),Instance.empty), ContextSet.empty) + | Declarations.Polymorphic_ind auctx -> + let inst, ctx = fresh_instance_from auctx inst in (((ind,i),inst), ctx) - else (((ind,i),Instance.empty), ContextSet.empty) + | Declarations.Cumulative_ind acumi -> + let inst, ctx = fresh_instance_from (ACumulativityInfo.univ_context acumi) inst in + (((ind,i),inst), ctx) let unsafe_constant_instance env c = let cb = lookup_constant c env in - if cb.Declarations.const_polymorphic then - let inst, ctx = unsafe_instance_from - (Declareops.universes_of_constant (Environ.opaque_tables env) cb) in - ((c, inst), ctx) - else ((c,Instance.empty), UContext.empty) + match cb.Declarations.const_universes with + | Declarations.Monomorphic_const _ -> + ((c,Instance.empty), UContext.empty) + | Declarations.Polymorphic_const auctx -> + let inst, ctx = unsafe_instance_from auctx in ((c, inst), ctx) let unsafe_inductive_instance env ind = let mib, mip = Inductive.lookup_mind_specif env ind in - if mib.Declarations.mind_polymorphic then - let inst, ctx = unsafe_instance_from mib.Declarations.mind_universes in - ((ind,inst), ctx) - else ((ind,Instance.empty), UContext.empty) + match mib.Declarations.mind_universes with + | Declarations.Monomorphic_ind _ -> ((ind,Instance.empty), UContext.empty) + | Declarations.Polymorphic_ind auctx -> + let inst, ctx = unsafe_instance_from auctx in ((ind,inst), ctx) + | Declarations.Cumulative_ind acumi -> + let inst, ctx = unsafe_instance_from (ACumulativityInfo.univ_context acumi) in + ((ind,inst), ctx) let unsafe_constructor_instance env (ind,i) = let mib, mip = Inductive.lookup_mind_specif env ind in - if mib.Declarations.mind_polymorphic then - let inst, ctx = unsafe_instance_from mib.Declarations.mind_universes in - (((ind,i),inst), ctx) - else (((ind,i),Instance.empty), UContext.empty) + match mib.Declarations.mind_universes with + | Declarations.Monomorphic_ind _ -> (((ind, i),Instance.empty), UContext.empty) + | Declarations.Polymorphic_ind auctx -> + let inst, ctx = unsafe_instance_from auctx in (((ind, i),inst), ctx) + | Declarations.Cumulative_ind acumi -> + let inst, ctx = unsafe_instance_from (ACumulativityInfo.univ_context acumi) in + (((ind, i),inst), ctx) open Globnames @@ -452,26 +468,49 @@ let type_of_reference env r = | ConstRef c -> let cb = Environ.lookup_constant c env in let ty = Typeops.type_of_constant_type env cb.const_type in - if cb.const_polymorphic then - let inst, ctx = fresh_instance_from (Declareops.universes_of_constant (Environ.opaque_tables env) cb) None in - Vars.subst_instance_constr inst ty, ctx - else ty, ContextSet.empty - + begin + match cb.const_universes with + | Monomorphic_const _ -> ty, ContextSet.empty + | Polymorphic_const auctx -> + let inst, ctx = fresh_instance_from auctx None in + Vars.subst_instance_constr inst ty, ctx + end | IndRef ind -> let (mib, oib as specif) = Inductive.lookup_mind_specif env ind in - if mib.mind_polymorphic then - let inst, ctx = fresh_instance_from mib.mind_universes None in + begin + match mib.mind_universes with + | Monomorphic_ind _ -> + let ty = Inductive.type_of_inductive env (specif, Univ.Instance.empty) in + ty, ContextSet.empty + | Polymorphic_ind auctx -> + let inst, ctx = fresh_instance_from auctx None in let ty = Inductive.type_of_inductive env (specif, inst) in - ty, ctx - else - let ty = Inductive.type_of_inductive env (specif, Univ.Instance.empty) in - ty, ContextSet.empty + ty, ctx + | Cumulative_ind cumi -> + let inst, ctx = + fresh_instance_from (ACumulativityInfo.univ_context cumi) None + in + let ty = Inductive.type_of_inductive env (specif, inst) in + ty, ctx + end + | ConstructRef cstr -> - let (mib,oib as specif) = Inductive.lookup_mind_specif env (inductive_of_constructor cstr) in - if mib.mind_polymorphic then - let inst, ctx = fresh_instance_from mib.mind_universes None in - Inductive.type_of_constructor (cstr,inst) specif, ctx - else Inductive.type_of_constructor (cstr,Instance.empty) specif, ContextSet.empty + let (mib,oib as specif) = + Inductive.lookup_mind_specif env (inductive_of_constructor cstr) + in + begin + match mib.mind_universes with + | Monomorphic_ind _ -> + Inductive.type_of_constructor (cstr,Instance.empty) specif, ContextSet.empty + | Polymorphic_ind auctx -> + let inst, ctx = fresh_instance_from auctx None in + Inductive.type_of_constructor (cstr,inst) specif, ctx + | Cumulative_ind cumi -> + let inst, ctx = + fresh_instance_from (ACumulativityInfo.univ_context cumi) None + in + Inductive.type_of_constructor (cstr,inst) specif, ctx + end let type_of_global t = type_of_reference (Global.env ()) t @@ -976,36 +1015,6 @@ let normalize_context_set ctx us algs = (* let normalize_conkey = Profile.declare_profile "normalize_context_set" *) (* let normalize_context_set a b c = Profile.profile3 normalize_conkey normalize_context_set a b c *) -let universes_of_constr c = - let rec aux s c = - match kind_of_term c with - | Const (_, u) | Ind (_, u) | Construct (_, u) -> - LSet.fold LSet.add (Instance.levels u) s - | Sort u when not (Sorts.is_small u) -> - let u = univ_of_sort u in - LSet.fold LSet.add (Universe.levels u) s - | _ -> fold_constr aux s c - in aux LSet.empty c - -let restrict_universe_context (univs,csts) s = - (* Universes that are not necessary to typecheck the term. - E.g. univs introduced by tactics and not used in the proof term. *) - let diff = LSet.diff univs s in - let rec aux diff candid univs ness = - let (diff', candid', univs', ness') = - Constraint.fold - (fun (l, d, r as c) (diff, candid, univs, csts) -> - if not (LSet.mem l diff) then - (LSet.remove r diff, candid, univs, Constraint.add c csts) - else if not (LSet.mem r diff) then - (LSet.remove l diff, candid, univs, Constraint.add c csts) - else (diff, Constraint.add c candid, univs, csts)) - candid (diff, Constraint.empty, univs, ness) - in - if ness' == ness then (LSet.diff univs diff', ness) - else aux diff' candid' univs' ness' - in aux diff csts univs Constraint.empty - let simplify_universe_context (univs,csts) = let uf = UF.create () in let noneqs = @@ -1118,3 +1127,14 @@ let solve_constraints_system levels level_bounds level_min = done; done; v + + +(** Operations for universe_info_ind *) + +(** Given a universe context representing constraints of an inductive + this function produces a UInfoInd.t that with the trivial subtyping relation. *) +let univ_inf_ind_from_universe_context univcst = + let freshunivs = Instance.of_array + (Array.map (fun _ -> new_univ_level ()) + (Instance.to_array (UContext.instance univcst))) + in CumulativityInfo.from_universe_context univcst freshunivs diff --git a/engine/universes.mli b/engine/universes.mli index 83ca1ea606..5ce5e4a42a 100644 --- a/engine/universes.mli +++ b/engine/universes.mli @@ -101,10 +101,10 @@ val eq_constr_universes_proj : env -> constr -> constr -> bool universe_constrai (** Build a fresh instance for a given context, its associated substitution and the instantiated constraints. *) -val fresh_instance_from_context : universe_context -> +val fresh_instance_from_context : abstract_universe_context -> universe_instance constrained -val fresh_instance_from : universe_context -> universe_instance option -> +val fresh_instance_from : abstract_universe_context -> universe_instance option -> universe_instance in_universe_context_set val fresh_sort_in_family : env -> sorts_family -> @@ -210,10 +210,6 @@ val unsafe_type_of_global : Globnames.global_reference -> types val nf_evars_and_universes_opt_subst : (existential -> constr option) -> universe_opt_subst -> constr -> constr -(** Shrink a universe context to a restricted set of variables *) - -val universes_of_constr : constr -> universe_set -val restrict_universe_context : universe_context_set -> universe_set -> universe_context_set val simplify_universe_context : universe_context_set -> universe_context_set * universe_level_subst @@ -227,3 +223,9 @@ val pr_universe_opt_subst : universe_opt_subst -> Pp.std_ppcmds val solve_constraints_system : universe option array -> universe array -> universe array -> universe array + +(** Operations for universe_info_ind *) + +(** Given a universe context representing constraints of an inductive + this function produces a UInfoInd.t that with the trivial subtyping relation. *) +val univ_inf_ind_from_universe_context : universe_context -> cumulativity_info diff --git a/grammar/argextend.mlp b/grammar/argextend.mlp index 36b9d612a0..8aecf0e0c8 100644 --- a/grammar/argextend.mlp +++ b/grammar/argextend.mlp @@ -178,7 +178,7 @@ let declare_vernac_argument loc s pr cl = let se = mlexpr_of_string s in let wit = <:expr< $lid:"wit_"^s$ >> in let pr_rules = match pr with - | None -> <:expr< fun _ _ _ _ -> str $str:"[No printer for "^s^"]"$ >> + | None -> <:expr< fun _ _ _ _ -> Pp.str $str:"[No printer for "^s^"]"$ >> | Some pr -> <:expr< fun _ _ _ -> $lid:pr$ >> in declare_str_items loc [ <:str_item< diff --git a/ide/ide_slave.ml b/ide/ide_slave.ml index 9c771cbef1..6298d9f093 100644 --- a/ide/ide_slave.ml +++ b/ide/ide_slave.ml @@ -341,6 +341,7 @@ let about () = { } let handle_exn (e, info) = + let (e, info) = ExplainErr.process_vernac_interp_error (e, info) in let dummy = Stateid.dummy in let loc_of e = match Loc.get_loc e with | Some loc -> Some (Loc.unloc loc) diff --git a/ide/texmacspp.ml b/ide/texmacspp.ml new file mode 100644 index 0000000000..8409c75218 --- /dev/null +++ b/ide/texmacspp.ml @@ -0,0 +1,769 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Xml_datatype +open Vernacexpr +open Constrexpr +open Names +open Misctypes +open Bigint +open Decl_kinds +open Extend +open Libnames +open Constrexpr_ops + +let unlock ?loc = + let start, stop = Option.cata Loc.unloc (0,0) loc in + (string_of_int start, string_of_int stop) + +let xmlWithLoc ?loc ename attr xml = + let start, stop = unlock ?loc in + Element(ename, [ "begin", start; "end", stop ] @ attr, xml) + +let get_fst_attr_in_xml_list attr xml_list = + let attrs_list = + List.map (function + | Element (_, attrs, _) -> (List.filter (fun (a,_) -> a = attr) attrs) + | _ -> []) + xml_list in + match List.flatten attrs_list with + | [] -> (attr, "") + | l -> (List.hd l) + +let backstep_loc xmllist = + let start_att = get_fst_attr_in_xml_list "begin" xmllist in + let stop_att = get_fst_attr_in_xml_list "end" (List.rev xmllist) in + [start_att ; stop_att] + +let compare_begin_att xml1 xml2 = + let att1 = get_fst_attr_in_xml_list "begin" [xml1] in + let att2 = get_fst_attr_in_xml_list "begin" [xml2] in + match att1, att2 with + | (_, s1), (_, s2) when s1 == "" || s2 == "" -> 0 + | (_, s1), (_, s2) when int_of_string s1 > int_of_string s2 -> 1 + | (_, s1), (_, s2) when int_of_string s1 < int_of_string s2 -> -1 + | _ -> 0 + +let xmlBeginSection ?loc name = xmlWithLoc ?loc "beginsection" ["name", name] [] + +let xmlEndSegment ?loc name = xmlWithLoc ?loc "endsegment" ["name", name] [] + +let xmlThm ?loc typ name xml = + xmlWithLoc ?loc "theorem" ["type", typ; "name", name] xml + +let xmlDef ?loc typ name xml = + xmlWithLoc ?loc "definition" ["type", typ; "name", name] xml + +let xmlNotation ?loc attr name xml = + xmlWithLoc ?loc "notation" (("name", name) :: attr) xml + +let xmlReservedNotation ?loc attr name = + xmlWithLoc ?loc "reservednotation" (("name", name) :: attr) [] + +let xmlCst ?loc ?(attr=[]) name = + xmlWithLoc ?loc "constant" (("name", name) :: attr) [] + +let xmlOperator ?loc ?(attr=[]) ?(pprules=[]) name = + xmlWithLoc ?loc "operator" + (("name", name) :: List.map (fun (a,b) -> "format"^a,b) pprules @ attr) [] + +let xmlApply ?loc ?(attr=[]) xml = xmlWithLoc ?loc "apply" attr xml + +let xmlToken ?loc ?(attr=[]) xml = xmlWithLoc ?loc "token" attr xml + +let xmlTyped xml = Element("typed", (backstep_loc xml), xml) + +let xmlReturn ?(attr=[]) xml = Element("return", attr, xml) + +let xmlCase xml = Element("case", [], xml) + +let xmlScrutinee ?(attr=[]) xml = Element("scrutinee", attr, xml) + +let xmlWith xml = Element("with", [], xml) + +let xmlAssign id xml = Element("assign", ["target",string_of_id id], [xml]) + +let xmlInductive ?loc kind xml = xmlWithLoc ?loc "inductive" ["kind",kind] xml + +let xmlCoFixpoint xml = Element("cofixpoint", [], xml) + +let xmlFixpoint xml = Element("fixpoint", [], xml) + +let xmlCheck ?loc xml = xmlWithLoc ?loc "check" [] xml + +let xmlAssumption ?loc kind xml = xmlWithLoc ?loc "assumption" ["kind",kind] xml + +let xmlComment ?loc xml = xmlWithLoc ?loc "comment" [] xml + +let xmlCanonicalStructure ?loc attr = xmlWithLoc ?loc "canonicalstructure" attr [] + +let xmlQed ?loc ?(attr=[]) = xmlWithLoc ?loc "qed" attr [] + +let xmlPatvar ?loc id = xmlWithLoc ?loc "patvar" ["id", id] [] + +let xmlReference ref = + let name = Libnames.string_of_reference ref in + let i, j = Option.cata Loc.unloc (0,0) (Libnames.loc_of_reference ref) in + let b, e = string_of_int i, string_of_int j in + Element("reference",["name", name; "begin", b; "end", e] ,[]) + +let xmlRequire ?loc ?(attr=[]) xml = xmlWithLoc ?loc "require" attr xml +let xmlImport ?loc ?(attr=[]) xml = xmlWithLoc ?loc "import" attr xml + +let xmlAddLoadPath ?loc ?(attr=[]) xml = xmlWithLoc ?loc "addloadpath" attr xml +let xmlRemoveLoadPath ?loc ?(attr=[]) = xmlWithLoc ?loc "removeloadpath" attr +let xmlAddMLPath ?loc ?(attr=[]) = xmlWithLoc ?loc "addmlpath" attr + +let xmlExtend ?loc xml = xmlWithLoc ?loc "extend" [] xml + +let xmlScope ?loc ?(attr=[]) action name xml = + xmlWithLoc ?loc "scope" (["name",name;"action",action] @ attr) xml + +let xmlProofMode ?loc name = xmlWithLoc ?loc "proofmode" ["name",name] [] + +let xmlProof ?loc xml = xmlWithLoc ?loc "proof" [] xml + +let xmlSectionSubsetDescr name ssd = + Element("sectionsubsetdescr",["name",name], + [PCData (Proof_using.to_string ssd)]) + +let xmlDeclareMLModule ?loc s = + xmlWithLoc ?loc "declarexmlmodule" [] + (List.map (fun x -> Element("path",["value",x],[])) s) + +(* tactics *) +let xmlLtac ?loc xml = xmlWithLoc ?loc "ltac" [] xml + +(* toplevel commands *) +let xmlGallina ?loc xml = xmlWithLoc ?loc "gallina" [] xml + +let xmlTODO ?loc x = + xmlWithLoc ?loc "todo" [] [PCData (Pp.string_of_ppcmds (Ppvernac.pr_vernac x))] + +let string_of_name n = + match n with + | Anonymous -> "_" + | Name id -> Id.to_string id + +let string_of_glob_sort s = + match s with + | GProp -> "Prop" + | GSet -> "Set" + | GType _ -> "Type" + +let string_of_cast_sort c = + match c with + | CastConv _ -> "CastConv" + | CastVM _ -> "CastVM" + | CastNative _ -> "CastNative" + | CastCoerce -> "CastCoerce" + +let string_of_case_style s = + match s with + | LetStyle -> "Let" + | IfStyle -> "If" + | LetPatternStyle -> "LetPattern" + | MatchStyle -> "Match" + | RegularStyle -> "Regular" + +let attribute_of_syntax_modifier sm = +match sm with + | SetItemLevel (sl, NumLevel n) -> + List.map (fun s -> ("itemlevel", s)) sl @ ["level", string_of_int n] + | SetItemLevel (sl, NextLevel) -> + List.map (fun s -> ("itemlevel", s)) sl @ ["level", "next"] + | SetLevel i -> ["level", string_of_int i] + | SetAssoc a -> + begin match a with + | NonA -> ["",""] + | RightA -> ["associativity", "right"] + | LeftA -> ["associativity", "left"] + end + | SetEntryType (s, _) -> ["entrytype", s] + | SetOnlyPrinting -> ["onlyprinting", ""] + | SetOnlyParsing -> ["onlyparsing", ""] + | SetCompatVersion v -> ["compat", Flags.pr_version v] + | SetFormat (system, (loc, s)) -> + let start, stop = unlock ?loc in + ["format-"^system, s; "begin", start; "end", stop] + +let string_of_assumption_kind l a many = + match l, a, many with + | (Discharge, Logical, true) -> "Hypotheses" + | (Discharge, Logical, false) -> "Hypothesis" + | (Discharge, Definitional, true) -> "Variables" + | (Discharge, Definitional, false) -> "Variable" + | (Global, Logical, true) -> "Axioms" + | (Global, Logical, false) -> "Axiom" + | (Global, Definitional, true) -> "Parameters" + | (Global, Definitional, false) -> "Parameter" + | (Local, Logical, true) -> "Local Axioms" + | (Local, Logical, false) -> "Local Axiom" + | (Local, Definitional, true) -> "Local Parameters" + | (Local, Definitional, false) -> "Local Parameter" + | (Global, Conjectural, _) -> "Conjecture" + | ((Discharge | Local), Conjectural, _) -> assert false + +let rec pp_bindlist bl = + let tlist = + List.flatten + (List.map + (fun (loc_names, _, e) -> + let names = + (List.map + (fun (loc, name) -> + xmlCst ?loc (string_of_name name)) loc_names) in + match e.CAst.v with + | CHole _ -> names + | _ -> names @ [pp_expr e]) + bl) in + match tlist with + | [e] -> e + | l -> xmlTyped l +and pp_decl_notation ((_, s), ce, sc) = (* don't know what it is for now *) + Element ("decl_notation", ["name", s], [pp_expr ce]) +and pp_local_binder lb = (* don't know what it is for now *) + match lb with + | CLocalDef ((loc, nam), ce, ty) -> + let attrs = ["name", string_of_name nam] in + let value = match ty with + Some t -> CAst.make ?loc:(Loc.merge_opt (constr_loc ce) (constr_loc t)) @@ CCast (ce, CastConv t) + | None -> ce in + pp_expr ~attr:attrs value + | CLocalAssum (namll, _, ce) -> + let ppl = + List.map (fun (loc, nam) -> (xmlCst ?loc (string_of_name nam))) namll in + xmlTyped (ppl @ [pp_expr ce]) + | CLocalPattern _ -> + assert false +and pp_local_decl_expr lde = (* don't know what it is for now *) + match lde with + | AssumExpr (_, ce) -> pp_expr ce + | DefExpr (_, ce, _) -> pp_expr ce +and pp_inductive_expr ((_, ((l, id),_)), lbl, ceo, _, cl_or_rdexpr) = + (* inductive_expr *) + let b,e = Option.cata Loc.unloc (0,0) l in + let location = ["begin", string_of_int b; "end", string_of_int e] in + [Element ("lident", ["name", Id.to_string id] @ location, [])] @ (* inductive name *) + begin match cl_or_rdexpr with + | Constructors coel -> List.map (fun (_, (_, ce)) -> pp_expr ce) coel + | RecordDecl (_, ldewwwl) -> + List.map (fun (((_, x), _), _) -> pp_local_decl_expr x) ldewwwl + end @ + begin match ceo with (* don't know what it is for now *) + | Some ce -> [pp_expr ce] + | None -> [] + end @ + (List.map pp_local_binder lbl) +and pp_recursion_order_expr optid roe = (* don't know what it is for now *) + let attrs = + match optid with + | None -> [] + | Some (loc, id) -> + let start, stop = unlock ?loc in + ["begin", start; "end", stop ; "name", Id.to_string id] in + let kind, expr = + match roe with + | CStructRec -> "struct", [] + | CWfRec e -> "rec", [pp_expr e] + | CMeasureRec (e, None) -> "mesrec", [pp_expr e] + | CMeasureRec (e, Some rel) -> "mesrec", [pp_expr e] @ [pp_expr rel] in + Element ("recursion_order", ["kind", kind] @ attrs, expr) +and pp_fixpoint_expr (((loc, id), pl), (optid, roe), lbl, ce, ceo) = + (* fixpoint_expr *) + let start, stop = unlock ?loc in + let id = Id.to_string id in + [Element ("lident", ["begin", start; "end", stop ; "name", id], [])] @ + (* fixpoint name *) + [pp_recursion_order_expr optid roe] @ + (List.map pp_local_binder lbl) @ + [pp_expr ce] @ + begin match ceo with (* don't know what it is for now *) + | Some ce -> [pp_expr ce] + | None -> [] + end +and pp_cofixpoint_expr (((loc, id), pl), lbl, ce, ceo) = (* cofixpoint_expr *) + (* Nota: it is like fixpoint_expr without (optid, roe) + * so could be merged if there is no more differences *) + let start, stop = unlock ?loc in + let id = Id.to_string id in + [Element ("lident", ["begin", start; "end", stop ; "name", id], [])] @ + (* cofixpoint name *) + (List.map pp_local_binder lbl) @ + [pp_expr ce] @ + begin match ceo with (* don't know what it is for now *) + | Some ce -> [pp_expr ce] + | None -> [] + end +and pp_lident (loc, id) = xmlCst ?loc (Id.to_string id) +and pp_simple_binder (idl, ce) = List.map pp_lident idl @ [pp_expr ce] +and pp_cases_pattern_expr {loc ; CAst.v = cpe} = + match cpe with + | CPatAlias (cpe, id) -> + xmlApply ?loc + (xmlOperator ?loc ~attr:["name", string_of_id id] "alias" :: + [pp_cases_pattern_expr cpe]) + | CPatCstr (ref, None, cpel2) -> + xmlApply ?loc + (xmlOperator ?loc "reference" + ~attr:["name", Libnames.string_of_reference ref] :: + [Element ("impargs", [], []); + Element ("args", [], (List.map pp_cases_pattern_expr cpel2))]) + | CPatCstr (ref, Some cpel1, cpel2) -> + xmlApply ?loc + (xmlOperator ?loc "reference" + ~attr:["name", Libnames.string_of_reference ref] :: + [Element ("impargs", [], (List.map pp_cases_pattern_expr cpel1)); + Element ("args", [], (List.map pp_cases_pattern_expr cpel2))]) + | CPatAtom optr -> + let attrs = match optr with + | None -> [] + | Some r -> ["name", Libnames.string_of_reference r] in + xmlApply ?loc (xmlOperator ?loc "atom" ~attr:attrs :: []) + | CPatOr cpel -> + xmlApply ?loc (xmlOperator ?loc "or" :: List.map pp_cases_pattern_expr cpel) + | CPatNotation (n, (subst_constr, subst_rec), cpel) -> + xmlApply ?loc + (xmlOperator ?loc "notation" :: + [xmlOperator ?loc n; + Element ("subst", [], + [Element ("subterms", [], + List.map pp_cases_pattern_expr subst_constr); + Element ("recsubterms", [], + List.map + (fun (cpel) -> + Element ("recsubterm", [], + List.map pp_cases_pattern_expr cpel)) + subst_rec)]); + Element ("args", [], (List.map pp_cases_pattern_expr cpel))]) + | CPatPrim tok -> pp_token ?loc tok + | CPatRecord rcl -> + xmlApply ?loc + (xmlOperator ?loc "record" :: + List.map (fun (r, cpe) -> + Element ("field", + ["reference", Libnames.string_of_reference r], + [pp_cases_pattern_expr cpe])) + rcl) + | CPatDelimiters (delim, cpe) -> + xmlApply ?loc + (xmlOperator ?loc "delimiter" ~attr:["name", delim] :: + [pp_cases_pattern_expr cpe]) + | CPatCast _ -> assert false +and pp_case_expr (e, name, pat) = + match name, pat with + | None, None -> xmlScrutinee [pp_expr e] + | Some (loc, name), None -> + let start, stop= unlock ?loc in + xmlScrutinee ~attr:["name", string_of_name name; + "begin", start; "end", stop] [pp_expr e] + | Some (loc, name), Some p -> + let start, stop= unlock ?loc in + xmlScrutinee ~attr:["name", string_of_name name; + "begin", start; "end", stop] + [Element ("in", [], [pp_cases_pattern_expr p]) ; pp_expr e] + | None, Some p -> + xmlScrutinee [Element ("in", [], [pp_cases_pattern_expr p]) ; pp_expr e] +and pp_branch_expr_list bel = + xmlWith + (List.map + (fun (_, (cpel, e)) -> + let ppcepl = + List.map pp_cases_pattern_expr (List.flatten (List.map snd cpel)) in + let ppe = [pp_expr e] in + xmlCase (ppcepl @ ppe)) + bel) +and pp_token ?loc tok = + let tokstr = + match tok with + | String s -> PCData s + | Numeral n -> PCData (to_string n) in + xmlToken ?loc [tokstr] +and pp_local_binder_list lbl = + let l = (List.map pp_local_binder lbl) in + Element ("recurse", (backstep_loc l), l) +and pp_const_expr_list cel = + let l = List.map pp_expr cel in + Element ("recurse", (backstep_loc l), l) +and pp_expr ?(attr=[]) { loc; CAst.v = e } = + match e with + | CRef (r, _) -> + xmlCst ?loc:(Libnames.loc_of_reference r) ~attr (Libnames.string_of_reference r) + | CProdN (bl, e) -> + xmlApply ?loc + (xmlOperator ?loc "forall" :: [pp_bindlist bl] @ [pp_expr e]) + | CApp ((_, hd), args) -> + xmlApply ?loc ~attr (pp_expr hd :: List.map (fun (e,_) -> pp_expr e) args) + | CAppExpl ((_, r, _), args) -> + xmlApply ?loc ~attr + (xmlCst ?loc:(Libnames.loc_of_reference r) (Libnames.string_of_reference r) + :: List.map pp_expr args) + | CNotation (notation, ([],[],[])) -> + xmlOperator ?loc notation + | CNotation (notation, (args, cell, lbll)) -> + let fmts = Notation.find_notation_extra_printing_rules notation in + let oper = xmlOperator ?loc notation ~pprules:fmts in + let cels = List.map pp_const_expr_list cell in + let lbls = List.map pp_local_binder_list lbll in + let args = List.map pp_expr args in + xmlApply ?loc (oper :: (List.sort compare_begin_att (args @ cels @ lbls))) + | CSort(s) -> + xmlOperator ?loc (string_of_glob_sort s) + | CDelimiters (scope, ce) -> + xmlApply ?loc (xmlOperator ?loc "delimiter" ~attr:["name", scope] :: + [pp_expr ce]) + | CPrim tok -> pp_token ?loc tok + | CGeneralization (kind, _, e) -> + let kind= match kind with + | Explicit -> "explicit" + | Implicit -> "implicit" in + xmlApply ?loc + (xmlOperator ?loc ~attr:["kind", kind] "generalization" :: [pp_expr e]) + | CCast (e, tc) -> + begin match tc with + | CastConv t | CastVM t |CastNative t -> + xmlApply ?loc + (xmlOperator ?loc ":" ~attr:["kind", (string_of_cast_sort tc)] :: + [pp_expr e; pp_expr t]) + | CastCoerce -> + xmlApply ?loc + (xmlOperator ?loc ":" ~attr:["kind", "CastCoerce"] :: + [pp_expr e]) + end + | CEvar (ek, cel) -> + let ppcel = List.map (fun (id,e) -> xmlAssign id (pp_expr e)) cel in + xmlApply ?loc + (xmlOperator ?loc "evar" ~attr:["id", string_of_id ek] :: + ppcel) + | CPatVar id -> xmlPatvar ?loc (string_of_id id) + | CHole (_, _, _) -> xmlCst ?loc ~attr "_" + | CIf (test, (_, ret), th, el) -> + let return = match ret with + | None -> [] + | Some r -> [xmlReturn [pp_expr r]] in + xmlApply ?loc + (xmlOperator ?loc "if" :: + return @ [pp_expr th] @ [pp_expr el]) + | CLetTuple (names, (_, ret), value, body) -> + let return = match ret with + | None -> [] + | Some r -> [xmlReturn [pp_expr r]] in + xmlApply ?loc + (xmlOperator ?loc "lettuple" :: + return @ + (List.map (fun (loc, var) -> xmlCst ?loc (string_of_name var)) names) @ + [pp_expr value; pp_expr body]) + | CCases (sty, ret, cel, bel) -> + let return = match ret with + | None -> [] + | Some r -> [xmlReturn [pp_expr r]] in + xmlApply ?loc + (xmlOperator ?loc ~attr:["style", (string_of_case_style sty)] "match" :: + (return @ + [Element ("scrutinees", [], List.map pp_case_expr cel)] @ + [pp_branch_expr_list bel])) + | CRecord _ -> assert false + | CLetIn ((varloc, var), value, typ, body) -> + let value = match typ with + | Some t -> + CAst.make ?loc:(Loc.merge_opt (constr_loc value) (constr_loc t)) (CCast (value, CastConv t)) + | None -> value in + xmlApply ?loc + (xmlOperator ?loc "let" :: + [xmlCst ?loc:varloc (string_of_name var) ; pp_expr value; pp_expr body]) + | CLambdaN (bl, e) -> + xmlApply ?loc + (xmlOperator ?loc "lambda" :: [pp_bindlist bl] @ [pp_expr e]) + | CCoFix (_, _) -> assert false + | CFix (lid, fel) -> + xmlApply ?loc + (xmlOperator ?loc "fix" :: + List.flatten (List.map + (fun (a,b,cl,c,d) -> pp_fixpoint_expr ((a,None),b,cl,c,Some d)) + fel)) + +let pp_comment c = + match c with + | CommentConstr e -> [pp_expr e] + | CommentString s -> [Element ("string", [], [PCData s])] + | CommentInt i -> [PCData (string_of_int i)] + +let rec tmpp ?loc v = + match v with + (* Control *) + | VernacLoad (verbose,f) -> + xmlWithLoc ?loc "load" ["verbose",string_of_bool verbose;"file",f] [] + | VernacTime (loc,e) -> + xmlApply ?loc (Element("time",[],[]) :: + [tmpp ?loc e]) + | VernacRedirect (s, (loc,e)) -> + xmlApply ?loc (Element("redirect",["path", s],[]) :: + [tmpp ?loc e]) + | VernacTimeout (s,e) -> + xmlApply ?loc (Element("timeout",["val",string_of_int s],[]) :: + [tmpp ?loc e]) + | VernacFail e -> xmlApply ?loc (Element("fail",[],[]) :: [tmpp ?loc e]) + + (* Syntax *) + | VernacSyntaxExtension (_, ((_, name), sml)) -> + let attrs = List.flatten (List.map attribute_of_syntax_modifier sml) in + xmlReservedNotation ?loc attrs name + + | VernacOpenCloseScope (_,(true,name)) -> xmlScope ?loc "open" name [] + | VernacOpenCloseScope (_,(false,name)) -> xmlScope ?loc "close" name [] + | VernacDelimiters (name,Some tag) -> + xmlScope ?loc "delimit" name ~attr:["delimiter",tag] [] + | VernacDelimiters (name,None) -> + xmlScope ?loc "undelimit" name ~attr:[] [] + | VernacInfix (_,((_,name),sml),ce,sn) -> + let attrs = List.flatten (List.map attribute_of_syntax_modifier sml) in + let sc_attr = + match sn with + | Some scope -> ["scope", scope] + | None -> [] in + xmlNotation ?loc (sc_attr @ attrs) name [pp_expr ce] + | VernacNotation (_, ce, (lstr, sml), sn) -> + let name = snd lstr in + let attrs = List.flatten (List.map attribute_of_syntax_modifier sml) in + let sc_attr = + match sn with + | Some scope -> ["scope", scope] + | None -> [] in + xmlNotation ?loc (sc_attr @ attrs) name [pp_expr ce] + | VernacBindScope _ as x -> xmlTODO ?loc x + | VernacNotationAddFormat _ as x -> xmlTODO ?loc x + | VernacUniverse _ + | VernacConstraint _ + | VernacPolymorphic (_, _) as x -> xmlTODO ?loc x + (* Gallina *) + | VernacDefinition (ldk, ((_,id),_), de) -> + let l, dk = + match ldk with + | Some l, dk -> (l, dk) + | None, dk -> (Global, dk) in (* Like in ppvernac.ml, l 585 *) + let e = + match de with + | ProveBody (_, ce) -> ce + | DefineBody (_, Some _, ce, None) -> ce + | DefineBody (_, None , ce, None) -> ce + | DefineBody (_, Some _, ce, Some _) -> ce + | DefineBody (_, None , ce, Some _) -> ce in + let str_dk = Kindops.string_of_definition_kind (l, false, dk) in + let str_id = Id.to_string id in + (xmlDef ?loc str_dk str_id [pp_expr e]) + | VernacStartTheoremProof (tk, [ Some ((_,id),_), ([], statement, None) ], b) -> + let str_tk = Kindops.string_of_theorem_kind tk in + let str_id = Id.to_string id in + (xmlThm ?loc str_tk str_id [pp_expr statement]) + | VernacStartTheoremProof _ as x -> xmlTODO ?loc x + | VernacEndProof pe -> + begin + match pe with + | Admitted -> xmlQed ?loc ?attr:None + | Proved (_, Some ((_, id), Some tk)) -> + let nam = Id.to_string id in + let typ = Kindops.string_of_theorem_kind tk in + xmlQed ?loc ~attr:["name", nam; "type", typ] + | Proved (_, Some ((_, id), None)) -> + let nam = Id.to_string id in + xmlQed ?loc ~attr:["name", nam] + | Proved _ -> xmlQed ?loc ?attr:None + end + | VernacExactProof _ as x -> xmlTODO ?loc x + | VernacAssumption ((l, a), _, sbwcl) -> + let binders = List.map (fun (_, (id, c)) -> (List.map fst id, c)) sbwcl in + let many = + List.length (List.flatten (List.map fst binders)) > 1 in + let exprs = + List.flatten (List.map pp_simple_binder binders) in + let l = match l with Some x -> x | None -> Decl_kinds.Global in + let kind = string_of_assumption_kind l a many in + xmlAssumption ?loc kind exprs + | VernacInductive (_, _, _, iednll) -> + let kind = + let (_, _, _, k, _), _ = List.hd iednll in + begin + match k with + | Record -> "Record" + | Structure -> "Structure" + | Inductive_kw -> "Inductive" + | CoInductive -> "CoInductive" + | Class _ -> "Class" + | Variant -> "Variant" + end in + let exprs = + List.flatten (* should probably not be flattened *) + (List.map + (fun (ie, dnl) -> (pp_inductive_expr ie) @ + (List.map pp_decl_notation dnl)) iednll) in + xmlInductive ?loc kind exprs + | VernacFixpoint (_, fednll) -> + let exprs = + List.flatten (* should probably not be flattened *) + (List.map + (fun (fe, dnl) -> (pp_fixpoint_expr fe) @ + (List.map pp_decl_notation dnl)) fednll) in + xmlFixpoint exprs + | VernacCoFixpoint (_, cfednll) -> + (* Nota: it is like VernacFixpoint without so could be merged *) + let exprs = + List.flatten (* should probably not be flattened *) + (List.map + (fun (cfe, dnl) -> (pp_cofixpoint_expr cfe) @ + (List.map pp_decl_notation dnl)) cfednll) in + xmlCoFixpoint exprs + | VernacScheme _ as x -> xmlTODO ?loc x + | VernacCombinedScheme _ as x -> xmlTODO ?loc x + + (* Gallina extensions *) + | VernacBeginSection (_, id) -> xmlBeginSection ?loc (Id.to_string id) + | VernacEndSegment (_, id) -> xmlEndSegment ?loc (Id.to_string id) + | VernacNameSectionHypSet _ as x -> xmlTODO ?loc x + | VernacRequire (from, import, l) -> + let import = match import with + | None -> [] + | Some true -> ["export","true"] + | Some false -> ["import","true"] + in + let from = match from with + | None -> [] + | Some r -> ["from", Libnames.string_of_reference r] + in + xmlRequire ?loc ~attr:(from @ import) (List.map (fun ref -> + xmlReference ref) l) + | VernacImport (true,l) -> + xmlImport ?loc ~attr:["export","true"] (List.map (fun ref -> + xmlReference ref) l) + | VernacImport (false,l) -> + xmlImport ?loc (List.map (fun ref -> xmlReference ref) l) + | VernacCanonical r -> + let attr = + match r with + | AN (Qualid (_, q)) -> ["qualid", string_of_qualid q] + | AN (Ident (_, id)) -> ["id", Id.to_string id] + | ByNotation (_, (s, _)) -> ["notation", s] in + xmlCanonicalStructure ?loc attr + | VernacCoercion _ as x -> xmlTODO ?loc x + | VernacIdentityCoercion _ as x -> xmlTODO ?loc x + + (* Type classes *) + | VernacInstance _ as x -> xmlTODO ?loc x + + | VernacContext _ as x -> xmlTODO ?loc x + + | VernacDeclareInstances _ as x -> xmlTODO ?loc x + + | VernacDeclareClass _ as x -> xmlTODO ?loc x + + (* Modules and Module Types *) + | VernacDeclareModule _ as x -> xmlTODO ?loc x + | VernacDefineModule _ as x -> xmlTODO ?loc x + | VernacDeclareModuleType _ as x -> xmlTODO ?loc x + | VernacInclude _ as x -> xmlTODO ?loc x + + (* Solving *) + + | (VernacSolveExistential _) as x -> + xmlLtac ?loc [PCData (Pp.string_of_ppcmds (Ppvernac.pr_vernac x))] + + (* Auxiliary file and library management *) + | VernacAddLoadPath (recf,name,None) -> + xmlAddLoadPath ?loc ~attr:["rec",string_of_bool recf;"path",name] [] + | VernacAddLoadPath (recf,name,Some dp) -> + xmlAddLoadPath ?loc ~attr:["rec",string_of_bool recf;"path",name] + [PCData (Names.DirPath.to_string dp)] + | VernacRemoveLoadPath name -> xmlRemoveLoadPath ?loc ~attr:["path",name] [] + | VernacAddMLPath (recf,name) -> + xmlAddMLPath ?loc ~attr:["rec",string_of_bool recf;"path",name] [] + | VernacDeclareMLModule sl -> xmlDeclareMLModule ?loc sl + | VernacChdir _ as x -> xmlTODO ?loc x + + (* State management *) + | VernacWriteState _ as x -> xmlTODO ?loc x + | VernacRestoreState _ as x -> xmlTODO ?loc x + + (* Resetting *) + | VernacResetName _ as x -> xmlTODO ?loc x + | VernacResetInitial as x -> xmlTODO ?loc x + | VernacBack _ as x -> xmlTODO ?loc x + | VernacBackTo _ -> PCData "VernacBackTo" + + (* Commands *) + | VernacCreateHintDb _ as x -> xmlTODO ?loc x + | VernacRemoveHints _ as x -> xmlTODO ?loc x + | VernacHints _ as x -> xmlTODO ?loc x + | VernacSyntacticDefinition ((_, name), (idl, ce), _, _) -> + let name = Id.to_string name in + let attrs = List.map (fun id -> ("id", Id.to_string id)) idl in + xmlNotation ?loc attrs name [pp_expr ce] + | VernacDeclareImplicits _ as x -> xmlTODO ?loc x + | VernacArguments _ as x -> xmlTODO ?loc x + | VernacArgumentsScope _ as x -> xmlTODO ?loc x + | VernacReserve _ as x -> xmlTODO ?loc x + | VernacGeneralizable _ as x -> xmlTODO ?loc x + | VernacSetOpacity _ as x -> xmlTODO ?loc x + | VernacSetStrategy _ as x -> xmlTODO ?loc x + | VernacUnsetOption _ as x -> xmlTODO ?loc x + | VernacSetOption _ as x -> xmlTODO ?loc x + | VernacSetAppendOption _ as x -> xmlTODO ?loc x + | VernacAddOption _ as x -> xmlTODO ?loc x + | VernacRemoveOption _ as x -> xmlTODO ?loc x + | VernacMemOption _ as x -> xmlTODO ?loc x + | VernacPrintOption _ as x -> xmlTODO ?loc x + | VernacCheckMayEval (_,_,e) -> xmlCheck ?loc [pp_expr e] + | VernacGlobalCheck _ as x -> xmlTODO ?loc x + | VernacDeclareReduction _ as x -> xmlTODO ?loc x + | VernacPrint _ as x -> xmlTODO ?loc x + | VernacSearch _ as x -> xmlTODO ?loc x + | VernacLocate _ as x -> xmlTODO ?loc x + | VernacRegister _ as x -> xmlTODO ?loc x + | VernacComments (cl) -> + xmlComment ?loc (List.flatten (List.map pp_comment cl)) + + (* Stm backdoor *) + | VernacStm _ as x -> xmlTODO ?loc x + + (* Proof management *) + | VernacGoal _ as x -> xmlTODO ?loc x + | VernacAbort _ as x -> xmlTODO ?loc x + | VernacAbortAll -> PCData "VernacAbortAll" + | VernacRestart as x -> xmlTODO ?loc x + | VernacUndo _ as x -> xmlTODO ?loc x + | VernacUndoTo _ as x -> xmlTODO ?loc x + | VernacBacktrack _ as x -> xmlTODO ?loc x + | VernacFocus _ as x -> xmlTODO ?loc x + | VernacUnfocus as x -> xmlTODO ?loc x + | VernacUnfocused as x -> xmlTODO ?loc x + | VernacBullet _ as x -> xmlTODO ?loc x + | VernacSubproof _ as x -> xmlTODO ?loc x + | VernacEndSubproof as x -> xmlTODO ?loc x + | VernacShow _ as x -> xmlTODO ?loc x + | VernacCheckGuard as x -> xmlTODO ?loc x + | VernacProof (tac,using) -> + let tac = None (** FIXME *) in + let using = Option.map (xmlSectionSubsetDescr "using") using in + xmlProof ?loc (Option.List.(cons tac (cons using []))) + | VernacProofMode name -> xmlProofMode ?loc name + + (* Toplevel control *) + | VernacToplevelControl _ as x -> xmlTODO ?loc x + + (* For extension *) + | VernacExtend _ as x -> + xmlExtend ?loc [PCData (Pp.string_of_ppcmds (Ppvernac.pr_vernac x))] + + (* Flags *) + | VernacProgram e -> xmlApply ?loc (Element("program",[],[]) :: [tmpp ?loc e]) + | VernacLocal (b,e) -> + xmlApply ?loc (Element("local",["flag",string_of_bool b],[]) :: + [tmpp ?loc e]) + +let tmpp ?loc v = + match tmpp ?loc v with + | Element("ltac",_,_) as x -> x + | xml -> xmlGallina ?loc [xml] diff --git a/interp/constrexpr_ops.ml b/interp/constrexpr_ops.ml index 79e0e61646..396dde0465 100644 --- a/interp/constrexpr_ops.ml +++ b/interp/constrexpr_ops.ml @@ -45,8 +45,11 @@ let names_of_local_binders bl = (**********************************************************************) (* Functions on constr_expr *) +(* Note: redundant Numeral representations such as -0 and +0 (or different + numbers of leading zeros) are considered different here. *) + let prim_token_eq t1 t2 = match t1, t2 with -| Numeral i1, Numeral i2 -> Bigint.equal i1 i2 +| Numeral (n1,s1), Numeral (n2,s2) -> String.equal n1 n2 && s1 == s2 | String s1, String s2 -> String.equal s1 s2 | _ -> false diff --git a/interp/constrextern.ml b/interp/constrextern.ml index d254520e0e..8a798bfb00 100644 --- a/interp/constrextern.ml +++ b/interp/constrextern.ml @@ -66,22 +66,138 @@ let print_universes = Detyping.print_universes (* This suppresses printing of primitive tokens (e.g. numeral) and notations *) let print_no_symbol = ref false -(* This tells which notations still not to used if print_no_symbol is true *) -let print_non_active_notations = ref ([] : interp_rule list) +(**********************************************************************) +(* Turning notations and scopes on and off for printing *) +module IRuleSet = Set.Make(struct + type t = interp_rule + let compare x y = Pervasives.compare x y + end) + +let inactive_notations_table = + Summary.ref ~name:"inactive_notations_table" (IRuleSet.empty) +let inactive_scopes_table = + Summary.ref ~name:"inactive_scopes_table" CString.Set.empty + +let show_scope scopt = + match scopt with + | None -> str "" + | Some sc -> spc () ++ str "in scope" ++ spc () ++ str sc + +let _show_inactive_notations () = + begin + if CString.Set.is_empty !inactive_scopes_table + then + Feedback.msg_notice (str "No inactive notation scopes.") + else + let _ = Feedback.msg_notice (str "Inactive notation scopes:") in + CString.Set.iter (fun sc -> Feedback.msg_notice (str " " ++ str sc)) + !inactive_scopes_table + end; + if IRuleSet.is_empty !inactive_notations_table + then + Feedback.msg_notice (str "No individual inactive notations.") + else + let _ = Feedback.msg_notice (str "Inactive notations:") in + IRuleSet.iter + (function + | NotationRule (scopt, ntn) -> + Feedback.msg_notice (str ntn ++ show_scope scopt) + | SynDefRule kn -> Feedback.msg_notice (str (Names.KerName.to_string kn))) + !inactive_notations_table + +let deactivate_notation nr = + match nr with + | SynDefRule kn -> + (* shouldn't we check wether it is well defined? *) + inactive_notations_table := IRuleSet.add nr !inactive_notations_table + | NotationRule (scopt, ntn) -> + match availability_of_notation (scopt, ntn) (scopt, []) with + | None -> user_err ~hdr:"Notation" + (str ntn ++ spc () ++ str "does not exist" + ++ (match scopt with + | None -> spc () ++ str "in the empty scope." + | Some _ -> show_scope scopt ++ str ".")) + | Some _ -> + if IRuleSet.mem nr !inactive_notations_table then + Feedback.msg_warning + (str "Notation" ++ spc () ++ str ntn ++ spc () + ++ str "is already inactive" ++ show_scope scopt ++ str ".") + else inactive_notations_table := IRuleSet.add nr !inactive_notations_table + +let reactivate_notation nr = + try + inactive_notations_table := + IRuleSet.remove nr !inactive_notations_table + with Not_found -> + match nr with + | NotationRule (scopt, ntn) -> + Feedback.msg_warning (str "Notation" ++ spc () ++ str ntn ++ spc () + ++ str "is already active" ++ show_scope scopt ++ + str ".") + | SynDefRule kn -> + Feedback.msg_warning + (str "Notation" ++ spc () ++ str (Names.KerName.to_string kn) + ++ spc () ++ str "is already active.") + + +let deactivate_scope sc = + ignore (find_scope sc); (* ensures that the scope exists *) + if CString.Set.mem sc !inactive_scopes_table + then + Feedback.msg_warning (str "Notation Scope" ++ spc () ++ str sc ++ spc () + ++ str "is already inactive.") + else + inactive_scopes_table := CString.Set.add sc !inactive_scopes_table + +let reactivate_scope sc = + try + inactive_scopes_table := CString.Set.remove sc !inactive_scopes_table + with Not_found -> + Feedback.msg_warning (str "Notation Scope" ++ spc () ++ str sc ++ spc () + ++ str "is already active.") + +let is_inactive_rule nr = + IRuleSet.mem nr !inactive_notations_table || + match nr with + | NotationRule (Some sc, ntn) -> CString.Set.mem sc !inactive_scopes_table + | NotationRule (None, ntn) -> false + | SynDefRule _ -> false + +(* args: notation, scope, activate/deactivate *) +let toggle_scope_printing ~scope ~activate = + if activate then + reactivate_scope scope + else + deactivate_scope scope + +let toggle_notation_printing ?scope ~notation ~activate = + if activate then + reactivate_notation (NotationRule (scope, notation)) + else + deactivate_notation (NotationRule (scope, notation)) (* This governs printing of projections using the dot notation symbols *) let print_projections = ref false let print_meta_as_hole = ref false -let with_arguments f = Flags.with_option print_arguments f -let with_implicits f = Flags.with_option print_implicits f -let with_coercions f = Flags.with_option print_coercions f let with_universes f = Flags.with_option print_universes f let with_meta_as_hole f = Flags.with_option print_meta_as_hole f let without_symbols f = Flags.with_option print_no_symbol f -let without_specific_symbols l f = - Flags.with_extra_values print_non_active_notations l f + +(* XXX: Where to put this in the library? Util maybe? *) +let protect_ref r nf f x = + let old_ref = !r in + r := nf !r; + try let res = f x in r := old_ref; res + with reraise -> + let reraise = Backtrace.add_backtrace reraise in + r := old_ref; + Exninfo.iraise reraise + +let without_specific_symbols l = + protect_ref inactive_notations_table + (fun tbl -> IRuleSet.(union (of_list l) tbl)) (**********************************************************************) (* Control printing of records *) @@ -239,23 +355,31 @@ let expand_curly_brackets loc mknot ntn l = let destPrim = function { CAst.v = CPrim t } -> Some t | _ -> None let destPatPrim = function { CAst.v = CPatPrim t } -> Some t | _ -> None +let is_number s = + let rec aux i = + Int.equal (String.length s) i || + match s.[i] with '0'..'9' -> aux (i+1) | _ -> false + in aux 0 + +let is_zero s = + let rec aux i = + Int.equal (String.length s) i || (s.[i] == '0' && aux (i+1)) + in aux 0 + let make_notation_gen loc ntn mknot mkprim destprim l = if has_curly_brackets ntn then expand_curly_brackets loc mknot ntn l else match ntn,List.map destprim l with (* Special case to avoid writing "- 3" for e.g. (Z.opp 3) *) - | "- _", [Some (Numeral p)] when Bigint.is_strictly_pos p -> + | "- _", [Some (Numeral (p,true))] when not (is_zero p) -> mknot (loc,ntn,([mknot (loc,"( _ )",l)])) | _ -> match decompose_notation_key ntn, l with - | [Terminal "-"; Terminal x], [] -> - (try mkprim (loc, Numeral (Bigint.neg (Bigint.of_string x))) - with Failure _ -> mknot (loc,ntn,[])) - | [Terminal x], [] -> - (try mkprim (loc, Numeral (Bigint.of_string x)) - with Failure _ -> mknot (loc,ntn,[])) - | _ -> - mknot (loc,ntn,l) + | [Terminal "-"; Terminal x], [] when is_number x -> + mkprim (loc, Numeral (x,false)) + | [Terminal x], [] when is_number x -> + mkprim (loc, Numeral (x,true)) + | _ -> mknot (loc,ntn,l) let make_notation loc ntn (terms,termlists,binders as subst) = if not (List.is_empty termlists) || not (List.is_empty binders) then @@ -390,7 +514,7 @@ and extern_notation_pattern (tmp_scope,scopes as allscopes) vars t = function | [] -> raise No_match | (keyrule,pat,n as _rule)::rules -> try - if List.mem keyrule !print_non_active_notations then raise No_match; + if is_inactive_rule keyrule then raise No_match; let loc = t.loc in match t.v with | PatCstr (cstr,_,na) -> @@ -406,8 +530,8 @@ let rec extern_notation_ind_pattern allscopes vars ind args = function | [] -> raise No_match | (keyrule,pat,n as _rule)::rules -> try - if List.mem keyrule !print_non_active_notations then raise No_match; - apply_notation_to_pattern (IndRef ind) + if is_inactive_rule keyrule then raise No_match; + apply_notation_to_pattern (IndRef ind) (match_notation_constr_ind_pattern ind args pat) allscopes vars keyrule with No_match -> extern_notation_ind_pattern allscopes vars ind args rules @@ -877,7 +1001,7 @@ and extern_notation (tmp_scope,scopes as allscopes) vars t = function | (keyrule,pat,n as _rule)::rules -> let loc = Glob_ops.loc_of_glob_constr t in try - if List.mem keyrule !print_non_active_notations then raise No_match; + if is_inactive_rule keyrule then raise No_match; (* Adjusts to the number of arguments expected by the notation *) let (t,args,argsscopes,argsimpls) = match t.v ,n with | GApp (f,args), Some n diff --git a/interp/constrextern.mli b/interp/constrextern.mli index ea627cff11..6c82168e48 100644 --- a/interp/constrextern.mli +++ b/interp/constrextern.mli @@ -59,16 +59,6 @@ val set_extern_reference : val get_extern_reference : unit -> (?loc:Loc.t -> Id.Set.t -> global_reference -> reference) -(** This governs printing of implicit arguments. If [with_implicits] is - on and not [with_arguments] then implicit args are printed prefixed - by "!"; if [with_implicits] and [with_arguments] are both on the - function and not the arguments is prefixed by "!" *) -val with_implicits : ('a -> 'b) -> 'a -> 'b -val with_arguments : ('a -> 'b) -> 'a -> 'b - -(** This forces printing of coercions *) -val with_coercions : ('a -> 'b) -> 'a -> 'b - (** This forces printing universe names of Type\{.\} *) val with_universes : ('a -> 'b) -> 'a -> 'b @@ -80,3 +70,13 @@ val without_specific_symbols : interp_rule list -> ('a -> 'b) -> 'a -> 'b (** This prints metas as anonymous holes *) val with_meta_as_hole : ('a -> 'b) -> 'a -> 'b + +(** Fine-grained activation and deactivation of notation printing. + *) +val toggle_scope_printing : + scope:Notation_term.scope_name -> activate:bool -> unit + +val toggle_notation_printing : + ?scope:Notation_term.scope_name -> notation:Constrexpr.notation -> activate:bool -> unit + + diff --git a/interp/constrintern.ml b/interp/constrintern.ml index 3d484a02da..89827300c4 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -786,7 +786,7 @@ let find_appl_head_data c = let scopes = find_arguments_scope ref in c, impls, scopes, [] | GApp ({ v = GRef (ref,_) },l) - when l != [] && Flags.version_strictly_greater Flags.V8_2 -> + when l != [] -> let n = List.length l in let impls = implicits_of_global ref in let scopes = find_arguments_scope ref in @@ -1219,6 +1219,11 @@ let alias_of als = match als.alias_ids with *) +let is_zero s = + let rec aux i = + Int.equal (String.length s) i || (s.[i] == '0' && aux (i+1)) + in aux 0 + let merge_subst s1 s2 = Id.Map.fold Id.Map.add s1 s2 let product_of_cases_patterns aliases idspl = @@ -1331,9 +1336,9 @@ let drop_notations_pattern looked_for genv = (* but not scopes in expl_pl *) let (argscs1,_) = find_remaining_scopes expl_pl pl g in CAst.make ?loc @@ RCPatCstr (g, List.map2 (in_pat_sc scopes) argscs1 expl_pl @ List.map (in_pat false scopes) pl, []) - | CPatNotation ("- _",([{ CAst.v = CPatPrim(Numeral p) }],[]),[]) - when Bigint.is_strictly_pos p -> - let pat, _df = Notation.interp_prim_token_cases_pattern_expr ?loc (ensure_kind false loc) (Numeral (Bigint.neg p)) scopes in + | CPatNotation ("- _",([{ CAst.v = CPatPrim(Numeral (p,true)) }],[]),[]) + when not (is_zero p) -> + let pat, _df = Notation.interp_prim_token_cases_pattern_expr ?loc (ensure_kind false loc) (Numeral (p,false)) scopes in rcp_of_glob pat | CPatNotation ("( _ )",([a],[]),[]) -> in_pat top scopes a @@ -1639,9 +1644,9 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = CAst.make ?loc @@ GLetIn (snd na, inc1, int, intern (push_name_env ntnvars (impls_term_list inc1) env na) c2) - | CNotation ("- _",([{ CAst.v = CPrim (Numeral p) }],[],[])) - when Bigint.is_strictly_pos p -> - intern env (CAst.make ?loc @@ CPrim (Numeral (Bigint.neg p))) + | CNotation ("- _",([{ CAst.v = CPrim (Numeral (p,true)) }],[],[])) + when not (is_zero p) -> + intern env (CAst.make ?loc @@ CPrim (Numeral (p,false))) | CNotation ("( _ )",([a],[],[])) -> intern env a | CNotation (ntn,args) -> intern_notation intern env ntnvars loc ntn args diff --git a/interp/notation.ml b/interp/notation.ml index 23332f7c45..300f6b1dd0 100644 --- a/interp/notation.ml +++ b/interp/notation.ml @@ -10,7 +10,6 @@ open CErrors open Util open Pp -open Bigint open Names open Term open Libnames @@ -319,16 +318,34 @@ let declare_prim_token_interpreter sc interp (patl,uninterp,b) = (glob_prim_constr_key pat) (sc,uninterp,b) !prim_token_key_table) patl -let mkNumeral n = Numeral n +let mkNumeral n = + if Bigint.is_pos_or_zero n then Numeral (Bigint.to_string n, true) + else Numeral (Bigint.to_string (Bigint.neg n), false) + +let ofNumeral n s = + if s then Bigint.of_string n else Bigint.neg (Bigint.of_string n) + let mkString = function | None -> None | Some s -> if Unicode.is_utf8 s then Some (String s) else None let delay dir int ?loc x = (dir, (fun () -> int ?loc x)) +type rawnum = Constrexpr.raw_natural_number * Constrexpr.sign + +let declare_rawnumeral_interpreter sc dir interp (patl,uninterp,inpat) = + declare_prim_token_interpreter sc + (fun cont ?loc -> function Numeral (n,s) -> delay dir interp ?loc (n,s) + | p -> cont ?loc p) + (patl, (fun r -> match uninterp r with + | None -> None + | Some (n,s) -> Some (Numeral (n,s))), inpat) + let declare_numeral_interpreter sc dir interp (patl,uninterp,inpat) = + let interp' ?loc (n,s) = interp ?loc (ofNumeral n s) in declare_prim_token_interpreter sc - (fun cont ?loc -> function Numeral n-> delay dir interp ?loc n | p -> cont ?loc p) + (fun cont ?loc -> function Numeral (n,s) -> delay dir interp' ?loc (n,s) + | p -> cont ?loc p) (patl, (fun r -> Option.map mkNumeral (uninterp r)), inpat) let declare_string_interpreter sc dir interp (patl,uninterp,inpat) = @@ -440,8 +457,8 @@ let find_notation ntn sc = (n.not_interp, n.not_location) let notation_of_prim_token = function - | Numeral n when is_pos_or_zero n -> to_string n - | Numeral n -> "- "^(to_string (neg n)) + | Numeral (n,true) -> n + | Numeral (n,false) -> "- "^n | String _ -> raise Not_found let find_prim_token check_allowed ?loc p sc = @@ -466,7 +483,8 @@ let interp_prim_token_gen ?loc g p local_scopes = with Not_found -> user_err ?loc ~hdr:"interp_prim_token" ((match p with - | Numeral n -> str "No interpretation for numeral " ++ str (to_string n) + | Numeral _ -> + str "No interpretation for numeral " ++ str (notation_of_prim_token p) | String s -> str "No interpretation for string " ++ qs s) ++ str ".") let interp_prim_token ?loc = diff --git a/interp/notation.mli b/interp/notation.mli index d271a88fe7..c739ec12fd 100644 --- a/interp/notation.mli +++ b/interp/notation.mli @@ -74,6 +74,11 @@ type 'a prim_token_interpreter = type 'a prim_token_uninterpreter = glob_constr list * (glob_constr -> 'a option) * cases_pattern_status +type rawnum = Constrexpr.raw_natural_number * Constrexpr.sign + +val declare_rawnumeral_interpreter : scope_name -> required_module -> + rawnum prim_token_interpreter -> rawnum prim_token_uninterpreter -> unit + val declare_numeral_interpreter : scope_name -> required_module -> bigint prim_token_interpreter -> bigint prim_token_uninterpreter -> unit diff --git a/intf/constrexpr.ml b/intf/constrexpr.ml index 614c097b5a..593b190a6b 100644 --- a/intf/constrexpr.ml +++ b/intf/constrexpr.ml @@ -31,8 +31,16 @@ type abstraction_kind = AbsLambda | AbsPi type proj_flag = int option (** [Some n] = proj of the n-th visible argument *) +(** Representation of integer literals that appear in Coq scripts. + We now use raw strings of digits in base 10 (big-endian), and a separate + sign flag. Note that this representation is not unique, due to possible + multiple leading zeros, and -0 = +0 *) + +type sign = bool +type raw_natural_number = string + type prim_token = - | Numeral of Bigint.bigint (** representation of integer literals that appear in Coq scripts. *) + | Numeral of raw_natural_number * sign | String of string type instance_expr = Misctypes.glob_level list diff --git a/intf/decl_kinds.ml b/intf/decl_kinds.ml index 8254b1b802..c15c009887 100644 --- a/intf/decl_kinds.ml +++ b/intf/decl_kinds.ml @@ -14,7 +14,9 @@ type binding_kind = Explicit | Implicit type polymorphic = bool -type private_flag = bool +type private_flag = bool + +type cumulative_inductive_flag = bool type theorem_kind = | Theorem diff --git a/intf/glob_term.ml b/intf/glob_term.ml index 5da20c9d1c..a35dae4aae 100644 --- a/intf/glob_term.ml +++ b/intf/glob_term.ml @@ -95,3 +95,19 @@ type closure = { and closed_glob_constr = { closure: closure; term: glob_constr } + +(** Ltac variable maps *) +type var_map = Pattern.constr_under_binders Id.Map.t +type uconstr_var_map = closed_glob_constr Id.Map.t +type unbound_ltac_var_map = Geninterp.Val.t Id.Map.t + +type ltac_var_map = { + ltac_constrs : var_map; + (** Ltac variables bound to constrs *) + ltac_uconstrs : uconstr_var_map; + (** Ltac variables bound to untyped constrs *) + ltac_idents: Id.t Id.Map.t; + (** Ltac variables bound to identifiers *) + ltac_genargs : unbound_ltac_var_map; + (** Ltac variables bound to other kinds of arguments *) +} diff --git a/intf/vernacexpr.ml b/intf/vernacexpr.ml index ab440c6b71..26a6db4ec9 100644 --- a/intf/vernacexpr.ml +++ b/intf/vernacexpr.ml @@ -96,17 +96,13 @@ type locatable = type showable = | ShowGoal of goal_reference - | ShowGoalImplicitly of int option | ShowProof - | ShowNode | ShowScript | ShowExistentials | ShowUniverses - | ShowTree | ShowProofNames | ShowIntros of bool | ShowMatch of reference - | ShowThesis type comment = | CommentConstr of constr_expr @@ -340,7 +336,7 @@ type vernac_expr = | VernacExactProof of constr_expr | VernacAssumption of (locality option * assumption_object_kind) * inline * (plident list * constr_expr) with_coercion list - | VernacInductive of private_flag * inductive_flag * (inductive_expr * decl_notation list) list + | VernacInductive of cumulative_inductive_flag * private_flag * inductive_flag * (inductive_expr * decl_notation list) list | VernacFixpoint of locality option * (fixpoint_expr * decl_notation list) list | VernacCoFixpoint of diff --git a/kernel/cbytegen.ml b/kernel/cbytegen.ml index 57b397e6f8..02c6a2c715 100644 --- a/kernel/cbytegen.ml +++ b/kernel/cbytegen.ml @@ -992,8 +992,8 @@ let compile_constant_body fail_on_error env univs = function let body = Mod_subst.force_constr sb in let instance_size = match univs with - | None -> 0 - | Some univ -> Univ.UContext.size univ + | Monomorphic_const _ -> 0 + | Polymorphic_const univ -> Univ.AUContext.size univ in match kind_of_term body with | Const (kn',u) when is_univ_copy instance_size u -> diff --git a/kernel/cbytegen.mli b/kernel/cbytegen.mli index c0f48641ce..48c2e45332 100644 --- a/kernel/cbytegen.mli +++ b/kernel/cbytegen.mli @@ -10,7 +10,7 @@ val compile : bool -> (* Fail on error with a nice user message, otherwise simpl (** init, fun, fv *) val compile_constant_body : bool -> - env -> constant_universes option -> constant_def -> body_code option + env -> constant_universes -> constant_def -> body_code option (** Shortcut of the previous function used during module strengthening *) diff --git a/kernel/cooking.ml b/kernel/cooking.ml index 4deadff0a7..0008653644 100644 --- a/kernel/cooking.ml +++ b/kernel/cooking.ml @@ -153,8 +153,7 @@ type inline = bool type result = constant_def * constant_type * projection_body option * - bool * constant_universes * inline - * Context.Named.t option + constant_universes * inline * Context.Named.t option let on_body ml hy f = function | Undef _ as x -> x @@ -179,17 +178,21 @@ let cook_constr { Opaqueproof.modlist ; abstract } c = abstract_constant_body (expmod c) hyps let lift_univs cb subst = - if cb.const_polymorphic && not (Univ.LMap.is_empty subst) then - let inst = Univ.UContext.instance cb.const_universes in - let cstrs = Univ.UContext.constraints cb.const_universes in - let len = Univ.LMap.cardinal subst in - let subst = - Array.fold_left_i (fun i acc v -> Univ.LMap.add (Level.var i) (Level.var (i + len)) acc) - subst (Univ.Instance.to_array inst) - in - let cstrs' = Univ.subst_univs_level_constraints subst cstrs in - subst, Univ.UContext.make (inst,cstrs') - else subst, cb.const_universes + match cb.const_universes with + | Monomorphic_const ctx -> subst, (Monomorphic_const ctx) + | Polymorphic_const auctx -> + if (Univ.LMap.is_empty subst) then + subst, (Polymorphic_const auctx) + else + let inst = Univ.AUContext.instance auctx in + let len = Univ.LMap.cardinal subst in + let subst = + Array.fold_left_i + (fun i acc v -> Univ.LMap.add (Level.var i) (Level.var (i + len)) acc) + subst (Univ.Instance.to_array inst) + in + let auctx' = Univ.subst_univs_level_abstract_universe_context subst auctx in + subst, (Polymorphic_const auctx') let cook_constant ~hcons env { from = cb; info } = let { Opaqueproof.modlist; abstract } = info in @@ -243,15 +246,15 @@ let cook_constant ~hcons env { from = cb; info } = proj_eta = etab, etat; proj_type = ty'; proj_body = c' } in - let univs = - let abs' = - if cb.const_polymorphic then abs_ctx - else instantiate_univ_context abs_ctx - in - UContext.union abs' univs + let univs = + match univs with + | Monomorphic_const ctx -> + Monomorphic_const (UContext.union (instantiate_univ_context abs_ctx) ctx) + | Polymorphic_const auctx -> + Polymorphic_const (AUContext.union abs_ctx auctx) in (body, typ, Option.map projection cb.const_proj, - cb.const_polymorphic, univs, cb.const_inline_code, + univs, cb.const_inline_code, Some const_hyps) (* let cook_constant_key = Profile.declare_profile "cook_constant" *) diff --git a/kernel/cooking.mli b/kernel/cooking.mli index 7d47eba23e..9db85a4a11 100644 --- a/kernel/cooking.mli +++ b/kernel/cooking.mli @@ -18,8 +18,7 @@ type inline = bool type result = constant_def * constant_type * projection_body option * - bool * constant_universes * inline - * Context.Named.t option + constant_universes * inline * Context.Named.t option val cook_constant : hcons:bool -> env -> recipe -> result val cook_constr : Opaqueproof.cooking_info -> Term.constr -> Term.constr diff --git a/kernel/declarations.ml b/kernel/declarations.ml index 71e228b19c..21651b3e21 100644 --- a/kernel/declarations.ml +++ b/kernel/declarations.ml @@ -64,7 +64,9 @@ type constant_def = | Def of constr Mod_subst.substituted (** or a transparent global definition *) | OpaqueDef of Opaqueproof.opaque (** or an opaque global definition *) -type constant_universes = Univ.universe_context +type constant_universes = + | Monomorphic_const of Univ.universe_context + | Polymorphic_const of Univ.abstract_universe_context (** The [typing_flags] are instructions to the type-checker which modify its behaviour. The typing flags used in the type-checking @@ -83,7 +85,6 @@ type constant_body = { const_body : constant_def; const_type : constant_type; const_body_code : Cemitcodes.to_patch_substituted option; - const_polymorphic : bool; (** Is it polymorphic or not *) const_universes : constant_universes; const_proj : projection_body option; const_inline_code : bool; @@ -168,6 +169,11 @@ type one_inductive_body = { mind_reloc_tbl : Cbytecodes.reloc_table; } +type abstract_inductive_universes = + | Monomorphic_ind of Univ.universe_context + | Polymorphic_ind of Univ.abstract_universe_context + | Cumulative_ind of Univ.abstract_cumulativity_info + type mutual_inductive_body = { mind_packets : one_inductive_body array; (** The component of the mutual inductive block *) @@ -186,9 +192,7 @@ type mutual_inductive_body = { mind_params_ctxt : Context.Rel.t; (** The context of parameters (includes let-in declaration) *) - mind_polymorphic : bool; (** Is it polymorphic or not *) - - mind_universes : Univ.universe_context; (** Local universe variables and constraints *) + mind_universes : abstract_inductive_universes; (** Information about monomorphic/polymorphic/cumulative inductives and their universes *) mind_private : bool option; (** allow pattern-matching: Some true ok, Some false blocked *) diff --git a/kernel/declareops.ml b/kernel/declareops.ml index 0a822d6fad..72b4907680 100644 --- a/kernel/declareops.ml +++ b/kernel/declareops.ml @@ -45,9 +45,15 @@ let hcons_template_arity ar = (** {6 Constants } *) let instantiate cb c = - if cb.const_polymorphic then - Vars.subst_instance_constr (Univ.UContext.instance cb.const_universes) c - else c + match cb.const_universes with + | Monomorphic_const _ -> c + | Polymorphic_const ctx -> + Vars.subst_instance_constr (Univ.AUContext.instance ctx) c + +let constant_is_polymorphic cb = + match cb.const_universes with + | Monomorphic_const _ -> false + | Polymorphic_const _ -> true let body_of_constant otab cb = match cb.const_body with | Undef _ -> None @@ -61,33 +67,56 @@ let type_of_constant cb = if t' == t then x else RegularArity t' | TemplateArity _ as x -> x -let constraints_of_constant otab cb = Univ.Constraint.union - (Univ.UContext.constraints cb.const_universes) - (match cb.const_body with - | Undef _ -> Univ.empty_constraint - | Def c -> Univ.empty_constraint - | OpaqueDef o -> - Univ.ContextSet.constraints (Opaqueproof.force_constraints otab o)) +let constraints_of_constant otab cb = + match cb.const_universes with + | Polymorphic_const ctx -> + Univ.UContext.constraints (Univ.instantiate_univ_context ctx) + | Monomorphic_const ctx -> + Univ.Constraint.union + (Univ.UContext.constraints ctx) + (match cb.const_body with + | Undef _ -> Univ.empty_constraint + | Def c -> Univ.empty_constraint + | OpaqueDef o -> + Univ.ContextSet.constraints (Opaqueproof.force_constraints otab o)) let universes_of_constant otab cb = match cb.const_body with - | Undef _ | Def _ -> cb.const_universes + | Undef _ | Def _ -> + begin + match cb.const_universes with + | Monomorphic_const ctx -> ctx + | Polymorphic_const ctx -> Univ.instantiate_univ_context ctx + end | OpaqueDef o -> - let body_uctxs = Opaqueproof.force_constraints otab o in - assert(not cb.const_polymorphic || Univ.ContextSet.is_empty body_uctxs); - let uctxs = Univ.ContextSet.of_context cb.const_universes in - Univ.ContextSet.to_context (Univ.ContextSet.union body_uctxs uctxs) + let body_uctxs = Opaqueproof.force_constraints otab o in + match cb.const_universes with + | Monomorphic_const ctx -> + let uctxs = Univ.ContextSet.of_context ctx in + Univ.ContextSet.to_context (Univ.ContextSet.union body_uctxs uctxs) + | Polymorphic_const ctx -> + assert(Univ.ContextSet.is_empty body_uctxs); + Univ.instantiate_univ_context ctx let universes_of_polymorphic_constant otab cb = - if cb.const_polymorphic then - let univs = universes_of_constant otab cb in - Univ.instantiate_univ_context univs - else Univ.UContext.empty + match cb.const_universes with + | Monomorphic_const _ -> Univ.UContext.empty + | Polymorphic_const ctx -> Univ.instantiate_univ_context ctx let constant_has_body cb = match cb.const_body with | Undef _ -> false | Def _ | OpaqueDef _ -> true +let constant_polymorphic_instance cb = + match cb.const_universes with + | Monomorphic_const _ -> Univ.Instance.empty + | Polymorphic_const ctx -> Univ.AUContext.instance ctx + +let constant_polymorphic_context cb = + match cb.const_universes with + | Monomorphic_const _ -> Univ.UContext.empty + | Polymorphic_const ctx -> Univ.instantiate_univ_context ctx + let is_opaque cb = match cb.const_body with | OpaqueDef _ -> true | Undef _ | Def _ -> false @@ -135,7 +164,6 @@ let subst_const_body sub cb = const_proj = proj'; const_body_code = Option.map (Cemitcodes.subst_to_patch_subst sub) cb.const_body_code; - const_polymorphic = cb.const_polymorphic; const_universes = cb.const_universes; const_inline_code = cb.const_inline_code; const_typing_flags = cb.const_typing_flags } @@ -166,11 +194,18 @@ let hcons_const_def = function Def (from_val (Term.hcons_constr constr)) | OpaqueDef _ as x -> x (* hashconsed when turned indirect *) +let hcons_const_universes cbu = + match cbu with + | Monomorphic_const ctx -> + Monomorphic_const (Univ.hcons_universe_context ctx) + | Polymorphic_const ctx -> + Polymorphic_const (Univ.hcons_abstract_universe_context ctx) + let hcons_const_body cb = { cb with const_body = hcons_const_def cb.const_body; const_type = hcons_const_type cb.const_type; - const_universes = Univ.hcons_universe_context cb.const_universes } + const_universes = hcons_const_universes cb.const_universes } (** {6 Inductive types } *) @@ -259,21 +294,36 @@ let subst_mind_body sub mib = mind_params_ctxt = Context.Rel.map (subst_mps sub) mib.mind_params_ctxt; mind_packets = Array.smartmap (subst_mind_packet sub) mib.mind_packets ; - mind_polymorphic = mib.mind_polymorphic; mind_universes = mib.mind_universes; mind_private = mib.mind_private; mind_typing_flags = mib.mind_typing_flags; } -let inductive_instance mib = - if mib.mind_polymorphic then - Univ.UContext.instance mib.mind_universes - else Univ.Instance.empty - -let inductive_context mib = - if mib.mind_polymorphic then - Univ.instantiate_univ_context mib.mind_universes - else Univ.UContext.empty +let inductive_polymorphic_instance mib = + match mib.mind_universes with + | Monomorphic_ind _ -> Univ.Instance.empty + | Polymorphic_ind ctx -> Univ.AUContext.instance ctx + | Cumulative_ind cumi -> + Univ.AUContext.instance (Univ.ACumulativityInfo.univ_context cumi) + +let inductive_polymorphic_context mib = + match mib.mind_universes with + | Monomorphic_ind _ -> Univ.UContext.empty + | Polymorphic_ind ctx -> Univ.instantiate_univ_context ctx + | Cumulative_ind cumi -> + Univ.instantiate_univ_context (Univ.ACumulativityInfo.univ_context cumi) + +let inductive_is_polymorphic mib = + match mib.mind_universes with + | Monomorphic_ind _ -> false + | Polymorphic_ind ctx -> true + | Cumulative_ind cumi -> true + +let inductive_is_cumulative mib = + match mib.mind_universes with + | Monomorphic_ind _ -> false + | Polymorphic_ind ctx -> false + | Cumulative_ind cumi -> true (** {6 Hash-consing of inductive declarations } *) @@ -301,11 +351,17 @@ let hcons_mind_packet oib = mind_user_lc = user; mind_nf_lc = nf } +let hcons_mind_universes miu = + match miu with + | Monomorphic_ind ctx -> Monomorphic_ind (Univ.hcons_universe_context ctx) + | Polymorphic_ind ctx -> Polymorphic_ind (Univ.hcons_abstract_universe_context ctx) + | Cumulative_ind cui -> Cumulative_ind (Univ.hcons_abstract_cumulativity_info cui) + let hcons_mind mib = { mib with mind_packets = Array.smartmap hcons_mind_packet mib.mind_packets; mind_params_ctxt = hcons_rel_context mib.mind_params_ctxt; - mind_universes = Univ.hcons_universe_context mib.mind_universes } + mind_universes = hcons_mind_universes mib.mind_universes } (** {6 Stm machinery } *) diff --git a/kernel/declareops.mli b/kernel/declareops.mli index 6650b6b7b0..811a28aa65 100644 --- a/kernel/declareops.mli +++ b/kernel/declareops.mli @@ -27,6 +27,12 @@ val subst_const_body : substitution -> constant_body -> constant_body val constant_has_body : constant_body -> bool +val constant_polymorphic_instance : constant_body -> universe_instance +val constant_polymorphic_context : constant_body -> universe_context + +(** Is the constant polymorphic? *) +val constant_is_polymorphic : constant_body -> bool + (** Accessing const_body, forcing access to opaque proof term if needed. Only use this function if you know what you're doing. *) @@ -66,8 +72,13 @@ val subst_wf_paths : substitution -> wf_paths -> wf_paths val subst_mind_body : substitution -> mutual_inductive_body -> mutual_inductive_body -val inductive_instance : mutual_inductive_body -> universe_instance -val inductive_context : mutual_inductive_body -> universe_context +val inductive_polymorphic_instance : mutual_inductive_body -> universe_instance +val inductive_polymorphic_context : mutual_inductive_body -> universe_context + +(** Is the inductive polymorphic? *) +val inductive_is_polymorphic : mutual_inductive_body -> bool +(** Is the inductive cumulative? *) +val inductive_is_cumulative : mutual_inductive_body -> bool (** {6 Kernel flags} *) diff --git a/kernel/entries.mli b/kernel/entries.mli index 1e07c96909..f133587c16 100644 --- a/kernel/entries.mli +++ b/kernel/entries.mli @@ -34,6 +34,11 @@ then, in i{^ th} block, [mind_entry_params] is [xn:Xn;...;x1:X1]; [mind_entry_lc] is [Ti1;...;Tini], defined in context [[A'1;...;A'p;x1:X1;...;xn:Xn]] where [A'i] is [Ai] generalized over [[x1:X1;...;xn:Xn]]. *) +type inductive_universes = + | Monomorphic_ind_entry of Univ.universe_context + | Polymorphic_ind_entry of Univ.universe_context + | Cumulative_ind_entry of Univ.cumulativity_info + type one_inductive_entry = { mind_entry_typename : Id.t; mind_entry_arity : constr; @@ -49,8 +54,9 @@ type mutual_inductive_entry = { mind_entry_finite : Decl_kinds.recursivity_kind; mind_entry_params : (Id.t * local_entry) list; mind_entry_inds : one_inductive_entry list; - mind_entry_polymorphic : bool; - mind_entry_universes : Univ.universe_context; + mind_entry_universes : inductive_universes; + (* universe constraints and the constraints for subtyping of + inductive types in the block. *) mind_entry_private : bool option; } diff --git a/kernel/environ.ml b/kernel/environ.ml index 5727bf2ea1..1ab5b7a8d1 100644 --- a/kernel/environ.ml +++ b/kernel/environ.ml @@ -228,8 +228,10 @@ let add_constant kn cb env = add_constant_key kn cb no_link_info env let constraints_of cb u = - let univs = cb.const_universes in - Univ.subst_instance_constraints u (Univ.UContext.constraints univs) + match cb.const_universes with + | Monomorphic_const _ -> Univ.Constraint.empty + | Polymorphic_const ctx -> + Univ.UContext.constraints (Univ.subst_instance_context u ctx) let map_regular_arity f = function | RegularArity a as ar -> @@ -240,15 +242,23 @@ let map_regular_arity f = function (* constant_type gives the type of a constant *) let constant_type env (kn,u) = let cb = lookup_constant kn env in - if cb.const_polymorphic then - let csts = constraints_of cb u in - (map_regular_arity (subst_instance_constr u) cb.const_type, csts) - else cb.const_type, Univ.Constraint.empty + match cb.const_universes with + | Monomorphic_const _ -> cb.const_type, Univ.Constraint.empty + | Polymorphic_const ctx -> + let csts = constraints_of cb u in + (map_regular_arity (subst_instance_constr u) cb.const_type, csts) + +let constant_instance env kn = + let cb = lookup_constant kn env in + match cb.const_universes with + | Monomorphic_const _ -> Univ.Instance.empty + | Polymorphic_const ctx -> Univ.AUContext.instance ctx let constant_context env kn = let cb = lookup_constant kn env in - if cb.const_polymorphic then cb.const_universes - else Univ.UContext.empty + match cb.const_universes with + | Monomorphic_const _ -> Univ.UContext.empty + | Polymorphic_const ctx -> Univ.instantiate_univ_context ctx type const_evaluation_result = NoBody | Opaque | IsProj @@ -259,10 +269,14 @@ let constant_value env (kn,u) = if cb.const_proj = None then match cb.const_body with | Def l_body -> - if cb.const_polymorphic then - let csts = constraints_of cb u in - (subst_instance_constr u (Mod_subst.force_constr l_body), csts) - else Mod_subst.force_constr l_body, Univ.Constraint.empty + begin + match cb.const_universes with + | Monomorphic_const _ -> + (Mod_subst.force_constr l_body, Univ.Constraint.empty) + | Polymorphic_const _ -> + let csts = constraints_of cb u in + (subst_instance_constr u (Mod_subst.force_constr l_body), csts) + end | OpaqueDef _ -> raise (NotEvaluableConst Opaque) | Undef _ -> raise (NotEvaluableConst NoBody) else raise (NotEvaluableConst IsProj) @@ -273,7 +287,7 @@ let constant_opt_value env cst = let constant_value_and_type env (kn, u) = let cb = lookup_constant kn env in - if cb.const_polymorphic then + if Declareops.constant_is_polymorphic cb then let cst = constraints_of cb u in let b' = match cb.const_body with | Def l_body -> Some (subst_instance_constr u (Mod_subst.force_constr l_body)) @@ -295,7 +309,7 @@ let constant_value_and_type env (kn, u) = (* constant_type gives the type of a constant *) let constant_type_in env (kn,u) = let cb = lookup_constant kn env in - if cb.const_polymorphic then + if Declareops.constant_is_polymorphic cb then map_regular_arity (subst_instance_constr u) cb.const_type else cb.const_type @@ -321,7 +335,7 @@ let evaluable_constant kn env = | Undef _ -> false let polymorphic_constant cst env = - (lookup_constant cst env).const_polymorphic + Declareops.constant_is_polymorphic (lookup_constant cst env) let polymorphic_pconstant (cst,u) env = if Univ.Instance.is_empty u then false @@ -353,7 +367,7 @@ let is_projection cst env = let lookup_mind = lookup_mind let polymorphic_ind (mind,i) env = - (lookup_mind mind env).mind_polymorphic + Declareops.inductive_is_polymorphic (lookup_mind mind env) let polymorphic_pind (ind,u) env = if Univ.Instance.is_empty u then false diff --git a/kernel/environ.mli b/kernel/environ.mli index b7431dbe5f..ae3afcb355 100644 --- a/kernel/environ.mli +++ b/kernel/environ.mli @@ -161,6 +161,9 @@ val constant_value_and_type : env -> constant puniverses -> (** The universe context associated to the constant, empty if not polymorphic *) val constant_context : env -> constant -> Univ.universe_context +(** The universe isntance associated to the constant, empty if not + polymorphic *) +val constant_instance : env -> constant -> Univ.universe_instance (* These functions should be called under the invariant that [env] already contains the constraints corresponding to the constant @@ -256,7 +259,7 @@ type unsafe_type_judgment = types punsafe_type_judgment (** {6 Compilation of global declaration } *) -val compile_constant_body : env -> constant_universes option -> constant_def -> Cemitcodes.body_code option +val compile_constant_body : env -> constant_universes -> constant_def -> Cemitcodes.body_code option exception Hyp_not_found diff --git a/kernel/indtypes.ml b/kernel/indtypes.ml index 1e13239bfc..00fbe27a70 100644 --- a/kernel/indtypes.ml +++ b/kernel/indtypes.ml @@ -207,6 +207,50 @@ let param_ccls paramsctxt = in List.fold_left fold [] paramsctxt +(* Check arities and constructors *) +let check_subtyping_arity_constructor env (subst : constr -> constr) (arcn : Term.types) numparams is_arity = + let numchecked = ref 0 in + let basic_check ev tp = + if !numchecked < numparams then () else conv_leq ev tp (subst tp); + numchecked := !numchecked + 1 + in + let check_typ typ typ_env = + match typ with + | LocalAssum (_, typ') -> + begin + try + basic_check typ_env typ'; Environ.push_rel typ typ_env + with NotConvertible -> + anomaly ~label:"bad inductive subtyping relation" (Pp.str "Invalid subtyping relation") + end + | _ -> anomaly (Pp.str "") + in + let typs, codom = dest_prod env arcn in + let last_env = Context.Rel.fold_outside check_typ typs ~init:env in + if not is_arity then basic_check last_env codom else () + +(* Check that the subtyping information inferred for inductive types in the block is correct. *) +(* This check produces a value of the unit type if successful or raises an anomaly if check fails. *) +let check_subtyping cumi paramsctxt env_ar inds = + let numparams = Context.Rel.nhyps paramsctxt in + let sbsubst = CumulativityInfo.subtyping_susbst cumi in + let dosubst = subst_univs_level_constr sbsubst in + let uctx = CumulativityInfo.univ_context cumi in + let instance_other = Univ.subst_univs_level_instance sbsubst (Univ.UContext.instance uctx) in + let constraints_other = Univ.subst_univs_level_constraints sbsubst (Univ.UContext.constraints uctx) in + let uctx_other = Univ.UContext.make (instance_other, constraints_other) in + let env = Environ.push_context uctx env_ar in + let env = Environ.push_context uctx_other env in + let env = push_context (CumulativityInfo.subtyp_context cumi) env in + (* process individual inductive types: *) + Array.iter (fun (id,cn,lc,(sign,arity)) -> + match arity with + | RegularArity (_, full_arity, _) -> + check_subtyping_arity_constructor env dosubst full_arity numparams true; + Array.iter (fun cnt -> check_subtyping_arity_constructor env dosubst cnt numparams false) lc + | TemplateArity _ -> () + ) inds + (* Type-check an inductive definition. Does not check positivity conditions. *) (* TODO check that we don't overgeneralize construcors/inductive arities with @@ -220,7 +264,13 @@ let typecheck_inductive env mie = (* Check unicity of names *) mind_check_names mie; (* Params are typed-checked here *) - let env' = push_context mie.mind_entry_universes env in + let univctx = + match mie.mind_entry_universes with + | Monomorphic_ind_entry ctx -> ctx + | Polymorphic_ind_entry ctx -> ctx + | Cumulative_ind_entry cumi -> Univ.CumulativityInfo.univ_context cumi + in + let env' = push_context univctx env in let (env_params,paramsctxt) = infer_local_decls env' mie.mind_entry_params in (* We first type arity of each inductive definition *) (* This allows building the environment of arities and to share *) @@ -339,12 +389,21 @@ let typecheck_inductive env mie = | _ (* Not an explicit occurrence of Type *) -> full_polymorphic () in - let arity = - if mie.mind_entry_polymorphic then full_polymorphic () - else template_polymorphic () + let arity = + match mie.mind_entry_universes with + | Monomorphic_ind_entry _ -> template_polymorphic () + | Polymorphic_ind_entry _ | Cumulative_ind_entry _ -> full_polymorphic () in (id,cn,lc,(sign,arity))) inds + in + (* Check that the subtyping information inferred for inductive types in the block is correct. *) + (* This check produces a value of the unit type if successful or raises an anomaly if check fails. *) + let () = + match mie.mind_entry_universes with + | Monomorphic_ind_entry _ -> () + | Polymorphic_ind_entry _ -> () + | Cumulative_ind_entry cumi -> check_subtyping cumi paramsctxt env_arities inds in (env_arities, env_ar_par, paramsctxt, inds) (************************************************************************) @@ -816,23 +875,31 @@ let compute_projections ((kn, _ as ind), u as indu) n x nparamargs params Array.of_list (List.rev kns), Array.of_list (List.rev pbs) -let build_inductive env p prv ctx env_ar paramsctxt kn isrecord isfinite inds nmr recargs = +let abstract_inductive_universes iu = + match iu with + | Monomorphic_ind_entry ctx -> (Univ.empty_level_subst, Monomorphic_ind ctx) + | Polymorphic_ind_entry ctx -> + let (inst, auctx) = Univ.abstract_universes ctx in (inst, Polymorphic_ind auctx) + | Cumulative_ind_entry cumi -> + let (inst, acumi) = Univ.abstract_cumulativity_info cumi in (inst, Cumulative_ind acumi) + +let build_inductive env prv iu env_ar paramsctxt kn isrecord isfinite inds nmr recargs = let ntypes = Array.length inds in (* Compute the set of used section variables *) let hyps = used_section_variables env inds in let nparamargs = Context.Rel.nhyps paramsctxt in let nparamsctxt = Context.Rel.length paramsctxt in - let subst, ctx = Univ.abstract_universes p ctx in - let paramsctxt = Vars.subst_univs_level_context subst paramsctxt in - let env_ar = - let ctx = Environ.rel_context env_ar in - let ctx' = Vars.subst_univs_level_context subst ctx in - Environ.push_rel_context ctx' env + let substunivs, aiu = abstract_inductive_universes iu in + let paramsctxt = Vars.subst_univs_level_context substunivs paramsctxt in + let env_ar = + let ctxunivs = Environ.rel_context env_ar in + let ctxunivs' = Vars.subst_univs_level_context substunivs ctxunivs in + Environ.push_rel_context ctxunivs' env in (* Check one inductive *) let build_one_packet (id,cnames,lc,(ar_sign,ar_kind)) recarg = (* Type of constructors in normal form *) - let lc = Array.map (Vars.subst_univs_level_constr subst) lc in + let lc = Array.map (Vars.subst_univs_level_constr substunivs) lc in let splayed_lc = Array.map (dest_prod_assum env_ar) lc in let nf_lc = Array.map (fun (d,b) -> it_mkProd_or_LetIn b d) splayed_lc in let consnrealdecls = @@ -851,8 +918,8 @@ let build_inductive env p prv ctx env_ar paramsctxt kn isrecord isfinite inds nm let s = sort_of_univ defs in let kelim = allowed_sorts info s in let ar = RegularArity - { mind_user_arity = Vars.subst_univs_level_constr subst ar; - mind_sort = sort_of_univ (Univ.subst_univs_level_universe subst defs); } in + { mind_user_arity = Vars.subst_univs_level_constr substunivs ar; + mind_sort = sort_of_univ (Univ.subst_univs_level_universe substunivs defs); } in ar, kelim in (* Assigning VM tags to constructors *) let nconst, nblock = ref 0, ref 0 in @@ -871,7 +938,7 @@ let build_inductive env p prv ctx env_ar paramsctxt kn isrecord isfinite inds nm (* Build the inductive packet *) { mind_typename = id; mind_arity = arkind; - mind_arity_ctxt = Vars.subst_univs_level_context subst ar_sign; + mind_arity_ctxt = Vars.subst_univs_level_context substunivs ar_sign; mind_nrealargs = Context.Rel.nhyps ar_sign - nparamargs; mind_nrealdecls = Context.Rel.length ar_sign - nparamsctxt; mind_kelim = kelim; @@ -893,10 +960,14 @@ let build_inductive env p prv ctx env_ar paramsctxt kn isrecord isfinite inds nm && Array.length pkt.mind_consnames == 1 && pkt.mind_consnrealargs.(0) > 0 -> (** The elimination criterion ensures that all projections can be defined. *) - let u = - if p then - subst_univs_level_instance subst (Univ.UContext.instance ctx) - else Univ.Instance.empty + let u = + let process auctx = + subst_univs_level_instance substunivs (Univ.AUContext.instance auctx) + in + match aiu with + | Monomorphic_ind _ -> Univ.Instance.empty + | Polymorphic_ind auctx -> process auctx + | Cumulative_ind acumi -> process (Univ.ACumulativityInfo.univ_context acumi) in let indsp = ((kn, 0), u) in let rctx, indty = decompose_prod_assum (subst1 (mkIndU indsp) pkt.mind_nf_lc.(0)) in @@ -919,8 +990,7 @@ let build_inductive env p prv ctx env_ar paramsctxt kn isrecord isfinite inds nm mind_nparams_rec = nmr; mind_params_ctxt = paramsctxt; mind_packets = packets; - mind_polymorphic = p; - mind_universes = ctx; + mind_universes = aiu; mind_private = prv; mind_typing_flags = Environ.typing_flags env; } @@ -935,7 +1005,6 @@ let check_inductive env kn mie = let chkpos = (Environ.typing_flags env).check_guarded in let (nmr,recargs) = check_positivity ~chkpos kn env_ar_par paramsctxt mie.mind_entry_finite inds in (* Build the inductive packets *) - build_inductive env mie.mind_entry_polymorphic mie.mind_entry_private - mie.mind_entry_universes + build_inductive env mie.mind_entry_private mie.mind_entry_universes env_ar paramsctxt kn mie.mind_entry_record mie.mind_entry_finite inds nmr recargs diff --git a/kernel/inductive.ml b/kernel/inductive.ml index f3b03252db..e81a1cb587 100644 --- a/kernel/inductive.ml +++ b/kernel/inductive.ml @@ -54,9 +54,13 @@ let inductive_paramdecls (mib,u) = Vars.subst_instance_context u mib.mind_params_ctxt let instantiate_inductive_constraints mib u = - if mib.mind_polymorphic then - Univ.subst_instance_constraints u (Univ.UContext.constraints mib.mind_universes) - else Univ.Constraint.empty + let process auctx = + Univ.UContext.constraints (Univ.subst_instance_context u auctx) + in + match mib.mind_universes with + | Monomorphic_ind _ -> Univ.Constraint.empty + | Polymorphic_ind auctx -> process auctx + | Cumulative_ind cumi -> process (Univ.ACumulativityInfo.univ_context cumi) (************************************************************************) diff --git a/kernel/kernel.mllib b/kernel/kernel.mllib index 2f49982ce2..0813315b5b 100644 --- a/kernel/kernel.mllib +++ b/kernel/kernel.mllib @@ -41,5 +41,5 @@ Nativelibrary Safe_typing Vm Csymtable -Vconv Declarations +Vconv diff --git a/kernel/mod_typing.ml b/kernel/mod_typing.ml index ff44f0f540..79016735bc 100644 --- a/kernel/mod_typing.ml +++ b/kernel/mod_typing.ml @@ -74,12 +74,13 @@ let rec check_with_def env struc (idl,(c,ctx)) mp equiv = as long as they have the right type *) let uctx = Declareops.universes_of_constant (opaque_tables env) cb in let uctx = (* Context of the spec *) - if cb.const_polymorphic then - Univ.instantiate_univ_context uctx - else uctx + match cb.const_universes with + | Monomorphic_const _ -> uctx + | Polymorphic_const auctx -> + Univ.instantiate_univ_context auctx in let c', univs, ctx' = - if not cb.const_polymorphic then + if not (Declareops.constant_is_polymorphic cb) then let env' = Environ.push_context ~strict:true uctx env' in let env' = Environ.push_context ~strict:true ctx env' in let c',cst = match cb.const_body with @@ -92,7 +93,7 @@ let rec check_with_def env struc (idl,(c,ctx)) mp equiv = | Def cs -> let c' = Mod_subst.force_constr cs in c, Reduction.infer_conv env' (Environ.universes env') c c' - in c', ctx, Univ.ContextSet.add_constraints cst (Univ.ContextSet.of_context ctx) + in c', Monomorphic_const ctx, Univ.ContextSet.add_constraints cst (Univ.ContextSet.of_context ctx) else let cus, ccst = Univ.UContext.dest uctx in let newus, cst = Univ.UContext.dest ctx in @@ -122,21 +123,17 @@ let rec check_with_def env struc (idl,(c,ctx)) mp equiv = in if not (Univ.Constraint.is_empty cst) then error_incorrect_with_constraint lab; - let subst, ctx = Univ.abstract_universes true ctx in - Vars.subst_univs_level_constr subst c, ctx, Univ.ContextSet.empty + let subst, ctx = Univ.abstract_universes ctx in + Vars.subst_univs_level_constr subst c, Polymorphic_const ctx, Univ.ContextSet.empty in let def = Def (Mod_subst.from_val c') in (* let ctx' = Univ.UContext.make (newus, cst) in *) - let univs = - if cb.const_polymorphic then Some cb.const_universes - else None - in let cb' = { cb with const_body = def; - const_universes = ctx ; + const_universes = univs ; const_body_code = Option.map Cemitcodes.from_val - (compile_constant_body env' univs def) } + (compile_constant_body env' cb.const_universes def) } in before@(lab,SFBconst(cb'))::after, c', ctx' else diff --git a/kernel/modops.ml b/kernel/modops.ml index 1f8b97ae6a..33d13f1ba0 100644 --- a/kernel/modops.ml +++ b/kernel/modops.ml @@ -35,6 +35,7 @@ type signature_mismatch_error = | NotConvertibleConstructorField of Id.t | NotConvertibleBodyField | NotConvertibleTypeField of env * types * types + | CumulativeStatusExpected of bool | PolymorphicStatusExpected of bool | NotSameConstructorNamesField | NotSameInductiveNameInBlockField @@ -327,12 +328,10 @@ let strengthen_const mp_from l cb resolver = |_ -> let kn = KerName.make2 mp_from l in let con = constant_of_delta_kn resolver kn in - let u = - if cb.const_polymorphic then - let u = Univ.UContext.instance cb.const_universes in - let s = Univ.make_instance_subst u in - Univ.subst_univs_level_instance s u - else Univ.Instance.empty + let u = + match cb.const_universes with + | Monomorphic_const _ -> Univ.Instance.empty + | Polymorphic_const ctx -> Univ.make_abstract_instance ctx in { cb with const_body = Def (Mod_subst.from_val (mkConstU (con,u))); diff --git a/kernel/modops.mli b/kernel/modops.mli index e9f3db6e91..4b533c7efd 100644 --- a/kernel/modops.mli +++ b/kernel/modops.mli @@ -94,6 +94,7 @@ type signature_mismatch_error = | NotConvertibleConstructorField of Id.t | NotConvertibleBodyField | NotConvertibleTypeField of env * types * types + | CumulativeStatusExpected of bool | PolymorphicStatusExpected of bool | NotSameConstructorNamesField | NotSameInductiveNameInBlockField diff --git a/kernel/nativecode.ml b/kernel/nativecode.ml index d3cd6b62a5..4941d64d82 100644 --- a/kernel/nativecode.ml +++ b/kernel/nativecode.ml @@ -1863,8 +1863,9 @@ let compile_constant env sigma prefix ~interactive con cb = match cb.const_proj with | None -> let u = - if cb.const_polymorphic then Univ.UContext.instance cb.const_universes - else Univ.Instance.empty + match cb.const_universes with + | Monomorphic_const _ -> Univ.Instance.empty + | Polymorphic_const ctx -> Univ.AUContext.instance ctx in begin match cb.const_body with | Def t -> @@ -1960,7 +1961,7 @@ let param_name = Name (id_of_string "params") let arg_name = Name (id_of_string "arg") let compile_mind prefix ~interactive mb mind stack = - let u = Declareops.inductive_instance mb in + let u = Declareops.inductive_polymorphic_instance mb in let f i stack ob = let gtype = Gtype((mind, i), Array.map snd ob.mind_reloc_tbl) in let j = push_symbol (SymbInd (mind,i)) in diff --git a/kernel/opaqueproof.ml b/kernel/opaqueproof.ml index 59e90ca2e9..3e15ff7401 100644 --- a/kernel/opaqueproof.ml +++ b/kernel/opaqueproof.ml @@ -16,7 +16,7 @@ type work_list = (Instance.t * Id.t array) Cmap.t * type cooking_info = { modlist : work_list; - abstract : Context.Named.t * Univ.universe_level_subst * Univ.UContext.t } + abstract : Context.Named.t * Univ.universe_level_subst * Univ.AUContext.t } type proofterm = (constr * Univ.universe_context_set) Future.computation type opaque = | Indirect of substitution list * DirPath.t * int (* subst, lib, index *) diff --git a/kernel/opaqueproof.mli b/kernel/opaqueproof.mli index 3897d5e51e..be1f4b13f0 100644 --- a/kernel/opaqueproof.mli +++ b/kernel/opaqueproof.mli @@ -49,7 +49,7 @@ type work_list = (Univ.Instance.t * Id.t array) Cmap.t * type cooking_info = { modlist : work_list; - abstract : Context.Named.t * Univ.universe_level_subst * Univ.UContext.t } + abstract : Context.Named.t * Univ.universe_level_subst * Univ.AUContext.t } (* The type has two caveats: 1) cook_constr is defined after diff --git a/kernel/reduction.ml b/kernel/reduction.ml index 427ce04c55..605e9f314c 100644 --- a/kernel/reduction.ml +++ b/kernel/reduction.ml @@ -191,6 +191,10 @@ type 'a universe_compare = { (* Might raise NotConvertible *) compare : env -> conv_pb -> sorts -> sorts -> 'a -> 'a; compare_instances: flex:bool -> Univ.Instance.t -> Univ.Instance.t -> 'a -> 'a; + conv_inductives : conv_pb -> (Declarations.mutual_inductive_body * int) -> Univ.Instance.t -> int -> + Univ.Instance.t -> int -> 'a -> 'a; + conv_constructors : (Declarations.mutual_inductive_body * int * int) -> + Univ.Instance.t -> int -> Univ.Instance.t -> int -> 'a -> 'a; } type 'a universe_state = 'a * 'a universe_compare @@ -206,6 +210,12 @@ let sort_cmp_universes env pb s0 s1 (u, check) = constructors. *) let convert_instances ~flex u u' (s, check) = (check.compare_instances ~flex u u' s, check) + +let convert_inductives cv_pb ind u1 sv1 u2 sv2 (s, check) = + (check.conv_inductives cv_pb ind u1 sv1 u2 sv2 s, check) + +let convert_constructors cons u1 sv1 u2 sv2 (s, check) = + (check.conv_constructors cons u1 sv1 u2 sv2 s, check) let conv_table_key infos k1 k2 cuniv = if k1 == k2 then cuniv else @@ -299,11 +309,11 @@ let unfold_projection infos p c = else None (* Conversion between [lft1]term1 and [lft2]term2 *) -let rec ccnv cv_pb l2r infos lft1 lft2 term1 term2 cuniv = - eqappr cv_pb l2r infos (lft1, (term1,[])) (lft2, (term2,[])) cuniv +let rec ccnv env cv_pb l2r infos lft1 lft2 term1 term2 cuniv = + eqappr env cv_pb l2r infos (lft1, (term1,[])) (lft2, (term2,[])) cuniv (* Conversion between [lft1](hd1 v1) and [lft2](hd2 v2) *) -and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = +and eqappr env cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = Control.check_for_interrupt (); (* First head reduce both terms *) let whd = whd_stack (infos_with_reds infos betaiotazeta) in @@ -328,13 +338,13 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = sort_cmp_universes (env_of_infos infos) cv_pb s1 s2 cuniv | (Meta n, Meta m) -> if Int.equal n m - then convert_stacks l2r infos lft1 lft2 v1 v2 cuniv + then convert_stacks env l2r infos lft1 lft2 v1 v2 cuniv else raise NotConvertible | _ -> raise NotConvertible) | (FEvar ((ev1,args1),env1), FEvar ((ev2,args2),env2)) -> if Evar.equal ev1 ev2 then - let cuniv = convert_stacks l2r infos lft1 lft2 v1 v2 cuniv in - convert_vect l2r infos el1 el2 + let cuniv = convert_stacks env l2r infos lft1 lft2 v1 v2 cuniv in + convert_vect env l2r infos el1 el2 (Array.map (mk_clos env1) args1) (Array.map (mk_clos env2) args2) cuniv else raise NotConvertible @@ -342,34 +352,34 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = (* 2 index known to be bound to no constant *) | (FRel n, FRel m) -> if Int.equal (reloc_rel n el1) (reloc_rel m el2) - then convert_stacks l2r infos lft1 lft2 v1 v2 cuniv + then convert_stacks env l2r infos lft1 lft2 v1 v2 cuniv else raise NotConvertible (* 2 constants, 2 local defined vars or 2 defined rels *) | (FFlex fl1, FFlex fl2) -> (try let cuniv = conv_table_key infos fl1 fl2 cuniv in - convert_stacks l2r infos lft1 lft2 v1 v2 cuniv + convert_stacks env l2r infos lft1 lft2 v1 v2 cuniv with NotConvertible | Univ.UniverseInconsistency _ -> (* else the oracle tells which constant is to be expanded *) let oracle = CClosure.oracle_of_infos infos in let (app1,app2) = if Conv_oracle.oracle_order Univ.out_punivs oracle l2r fl1 fl2 then match unfold_reference infos fl1 with - | Some def1 -> ((lft1, whd def1 v1), appr2) + | Some def1 -> ((lft1, (def1, v1)), appr2) | None -> (match unfold_reference infos fl2 with - | Some def2 -> (appr1, (lft2, whd def2 v2)) + | Some def2 -> (appr1, (lft2, (def2, v2))) | None -> raise NotConvertible) else match unfold_reference infos fl2 with - | Some def2 -> (appr1, (lft2, whd def2 v2)) + | Some def2 -> (appr1, (lft2, (def2, v2))) | None -> (match unfold_reference infos fl1 with - | Some def1 -> ((lft1, whd def1 v1), appr2) + | Some def1 -> ((lft1, (def1, v1)), appr2) | None -> raise NotConvertible) in - eqappr cv_pb l2r infos app1 app2 cuniv) + eqappr env cv_pb l2r infos app1 app2 cuniv) | (FProj (p1,c1), FProj (p2, c2)) -> (* Projections: prefer unfolding to first-order unification, @@ -377,42 +387,42 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = form *) (match unfold_projection infos p1 c1 with | Some (def1,s1) -> - eqappr cv_pb l2r infos (lft1, whd def1 (s1 :: v1)) appr2 cuniv + eqappr env cv_pb l2r infos (lft1, (def1, (s1 :: v1))) appr2 cuniv | None -> match unfold_projection infos p2 c2 with | Some (def2,s2) -> - eqappr cv_pb l2r infos appr1 (lft2, whd def2 (s2 :: v2)) cuniv + eqappr env cv_pb l2r infos appr1 (lft2, (def2, (s2 :: v2))) cuniv | None -> if Constant.equal (Projection.constant p1) (Projection.constant p2) && compare_stack_shape v1 v2 then - let u1 = ccnv CONV l2r infos el1 el2 c1 c2 cuniv in - convert_stacks l2r infos lft1 lft2 v1 v2 u1 + let u1 = ccnv env CONV l2r infos el1 el2 c1 c2 cuniv in + convert_stacks env l2r infos lft1 lft2 v1 v2 u1 else (* Two projections in WHNF: unfold *) raise NotConvertible) | (FProj (p1,c1), t2) -> (match unfold_projection infos p1 c1 with | Some (def1,s1) -> - eqappr cv_pb l2r infos (lft1, whd def1 (s1 :: v1)) appr2 cuniv + eqappr env cv_pb l2r infos (lft1, (def1, (s1 :: v1))) appr2 cuniv | None -> (match t2 with | FFlex fl2 -> (match unfold_reference infos fl2 with | Some def2 -> - eqappr cv_pb l2r infos appr1 (lft2, whd def2 v2) cuniv + eqappr env cv_pb l2r infos appr1 (lft2, (def2, v2)) cuniv | None -> raise NotConvertible) | _ -> raise NotConvertible)) | (t1, FProj (p2,c2)) -> (match unfold_projection infos p2 c2 with | Some (def2,s2) -> - eqappr cv_pb l2r infos appr1 (lft2, whd def2 (s2 :: v2)) cuniv + eqappr env cv_pb l2r infos appr1 (lft2, (def2, (s2 :: v2))) cuniv | None -> (match t1 with | FFlex fl1 -> (match unfold_reference infos fl1 with | Some def1 -> - eqappr cv_pb l2r infos (lft1, whd def1 v1) appr2 cuniv + eqappr env cv_pb l2r infos (lft1, (def1, v1)) appr2 cuniv | None -> raise NotConvertible) | _ -> raise NotConvertible)) @@ -424,15 +434,15 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = anomaly (Pp.str "conversion was given ill-typed terms (FLambda)."); let (_,ty1,bd1) = destFLambda mk_clos hd1 in let (_,ty2,bd2) = destFLambda mk_clos hd2 in - let cuniv = ccnv CONV l2r infos el1 el2 ty1 ty2 cuniv in - ccnv CONV l2r infos (el_lift el1) (el_lift el2) bd1 bd2 cuniv + let cuniv = ccnv env CONV l2r infos el1 el2 ty1 ty2 cuniv in + ccnv env CONV l2r infos (el_lift el1) (el_lift el2) bd1 bd2 cuniv | (FProd (_,c1,c2), FProd (_,c'1,c'2)) -> if not (is_empty_stack v1 && is_empty_stack v2) then anomaly (Pp.str "conversion was given ill-typed terms (FProd)."); (* Luo's system *) - let cuniv = ccnv CONV l2r infos el1 el2 c1 c'1 cuniv in - ccnv cv_pb l2r infos (el_lift el1) (el_lift el2) c2 c'2 cuniv + let cuniv = ccnv env CONV l2r infos el1 el2 c1 c'1 cuniv in + ccnv env cv_pb l2r infos (el_lift el1) (el_lift el2) c2 c'2 cuniv (* Eta-expansion on the fly *) | (FLambda _, _) -> @@ -442,7 +452,7 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = anomaly (Pp.str "conversion was given unreduced term (FLambda).") in let (_,_ty1,bd1) = destFLambda mk_clos hd1 in - eqappr CONV l2r infos + eqappr env CONV l2r infos (el_lift lft1, (bd1, [])) (el_lift lft2, (hd2, eta_expand_stack v2)) cuniv | (_, FLambda _) -> let () = match v2 with @@ -451,66 +461,88 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = anomaly (Pp.str "conversion was given unreduced term (FLambda).") in let (_,_ty2,bd2) = destFLambda mk_clos hd2 in - eqappr CONV l2r infos + eqappr env CONV l2r infos (el_lift lft1, (hd1, eta_expand_stack v1)) (el_lift lft2, (bd2, [])) cuniv (* only one constant, defined var or defined rel *) | (FFlex fl1, c2) -> (match unfold_reference infos fl1 with | Some def1 -> - eqappr cv_pb l2r infos (lft1, whd def1 v1) appr2 cuniv + eqappr env cv_pb l2r infos (lft1, (def1, v1)) appr2 cuniv | None -> match c2 with | FConstruct ((ind2,j2),u2) -> (try let v2, v1 = eta_expand_ind_stack (info_env infos) ind2 hd2 v2 (snd appr1) - in convert_stacks l2r infos lft1 lft2 v1 v2 cuniv + in convert_stacks env l2r infos lft1 lft2 v1 v2 cuniv with Not_found -> raise NotConvertible) | _ -> raise NotConvertible) | (c1, FFlex fl2) -> (match unfold_reference infos fl2 with | Some def2 -> - eqappr cv_pb l2r infos appr1 (lft2, whd def2 v2) cuniv + eqappr env cv_pb l2r infos appr1 (lft2, (def2, v2)) cuniv | None -> match c1 with | FConstruct ((ind1,j1),u1) -> (try let v1, v2 = eta_expand_ind_stack (info_env infos) ind1 hd1 v1 (snd appr2) - in convert_stacks l2r infos lft1 lft2 v1 v2 cuniv + in convert_stacks env l2r infos lft1 lft2 v1 v2 cuniv with Not_found -> raise NotConvertible) | _ -> raise NotConvertible) (* Inductive types: MutInd MutConstruct Fix Cofix *) - | (FInd (ind1,u1), FInd (ind2,u2)) -> - if eq_ind ind1 ind2 - then - (let cuniv = convert_instances ~flex:false u1 u2 cuniv in - convert_stacks l2r infos lft1 lft2 v1 v2 cuniv) - else raise NotConvertible + if eq_ind ind1 ind2 then + if Univ.Instance.length u1 = 0 || Univ.Instance.length u2 = 0 then + let cuniv = convert_instances ~flex:false u1 u2 cuniv in + convert_stacks env l2r infos lft1 lft2 v1 v2 cuniv + else + let mind = Environ.lookup_mind (fst ind1) env in + let cuniv = + match mind.Declarations.mind_universes with + | Declarations.Monomorphic_ind _ | Declarations.Polymorphic_ind _ -> + convert_instances ~flex:false u1 u2 cuniv + | Declarations.Cumulative_ind cumi -> + convert_inductives cv_pb (mind, snd ind1) u1 (CClosure.stack_args_size v1) + u2 (CClosure.stack_args_size v2) cuniv + in + convert_stacks env l2r infos lft1 lft2 v1 v2 cuniv + else raise NotConvertible | (FConstruct ((ind1,j1),u1), FConstruct ((ind2,j2),u2)) -> - if Int.equal j1 j2 && eq_ind ind1 ind2 - then - (let cuniv = convert_instances ~flex:false u1 u2 cuniv in - convert_stacks l2r infos lft1 lft2 v1 v2 cuniv) - else raise NotConvertible + if Int.equal j1 j2 && eq_ind ind1 ind2 then + if Univ.Instance.length u1 = 0 || Univ.Instance.length u2 = 0 then + let cuniv = convert_instances ~flex:false u1 u2 cuniv in + convert_stacks env l2r infos lft1 lft2 v1 v2 cuniv + else + let mind = Environ.lookup_mind (fst ind1) env in + let cuniv = + match mind.Declarations.mind_universes with + | Declarations.Monomorphic_ind _ | Declarations.Polymorphic_ind _ -> + convert_instances ~flex:false u1 u2 cuniv + | Declarations.Cumulative_ind _ -> + convert_constructors + (mind, snd ind1, j1) u1 (CClosure.stack_args_size v1) + u2 (CClosure.stack_args_size v2) cuniv + in + convert_stacks env l2r infos lft1 lft2 v1 v2 cuniv + else raise NotConvertible (* Eta expansion of records *) | (FConstruct ((ind1,j1),u1), _) -> (try let v1, v2 = eta_expand_ind_stack (info_env infos) ind1 hd1 v1 (snd appr2) - in convert_stacks l2r infos lft1 lft2 v1 v2 cuniv + in convert_stacks env l2r infos lft1 lft2 v1 v2 cuniv with Not_found -> raise NotConvertible) | (_, FConstruct ((ind2,j2),u2)) -> (try let v2, v1 = eta_expand_ind_stack (info_env infos) ind2 hd2 v2 (snd appr1) - in convert_stacks l2r infos lft1 lft2 v1 v2 cuniv + in convert_stacks env l2r infos lft1 lft2 v1 v2 cuniv with Not_found -> raise NotConvertible) | (FFix (((op1, i1),(_,tys1,cl1)),e1), FFix(((op2, i2),(_,tys2,cl2)),e2)) -> @@ -521,11 +553,11 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = let fty2 = Array.map (mk_clos e2) tys2 in let fcl1 = Array.map (mk_clos (subs_liftn n e1)) cl1 in let fcl2 = Array.map (mk_clos (subs_liftn n e2)) cl2 in - let cuniv = convert_vect l2r infos el1 el2 fty1 fty2 cuniv in + let cuniv = convert_vect env l2r infos el1 el2 fty1 fty2 cuniv in let cuniv = - convert_vect l2r infos + convert_vect env l2r infos (el_liftn n el1) (el_liftn n el2) fcl1 fcl2 cuniv in - convert_stacks l2r infos lft1 lft2 v1 v2 cuniv + convert_stacks env l2r infos lft1 lft2 v1 v2 cuniv else raise NotConvertible | (FCoFix ((op1,(_,tys1,cl1)),e1), FCoFix((op2,(_,tys2,cl2)),e2)) -> @@ -536,11 +568,11 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = let fty2 = Array.map (mk_clos e2) tys2 in let fcl1 = Array.map (mk_clos (subs_liftn n e1)) cl1 in let fcl2 = Array.map (mk_clos (subs_liftn n e2)) cl2 in - let cuniv = convert_vect l2r infos el1 el2 fty1 fty2 cuniv in + let cuniv = convert_vect env l2r infos el1 el2 fty1 fty2 cuniv in let cuniv = - convert_vect l2r infos + convert_vect env l2r infos (el_liftn n el1) (el_liftn n el2) fcl1 fcl2 cuniv in - convert_stacks l2r infos lft1 lft2 v1 v2 cuniv + convert_stacks env l2r infos lft1 lft2 v1 v2 cuniv else raise NotConvertible (* Should not happen because both (hd1,v1) and (hd2,v2) are in whnf *) @@ -551,13 +583,13 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = (* In all other cases, terms are not convertible *) | _ -> raise NotConvertible -and convert_stacks l2r infos lft1 lft2 stk1 stk2 cuniv = +and convert_stacks env l2r infos lft1 lft2 stk1 stk2 cuniv = compare_stacks - (fun (l1,t1) (l2,t2) cuniv -> ccnv CONV l2r infos l1 l2 t1 t2 cuniv) + (fun (l1,t1) (l2,t2) cuniv -> ccnv env CONV l2r infos l1 l2 t1 t2 cuniv) (eq_ind) lft1 stk1 lft2 stk2 cuniv -and convert_vect l2r infos lft1 lft2 v1 v2 cuniv = +and convert_vect env l2r infos lft1 lft2 v1 v2 cuniv = let lv1 = Array.length v1 in let lv2 = Array.length v2 in if Int.equal lv1 lv2 @@ -565,7 +597,7 @@ and convert_vect l2r infos lft1 lft2 v1 v2 cuniv = let rec fold n cuniv = if n >= lv1 then cuniv else - let cuniv = ccnv CONV l2r infos lft1 lft2 v1.(n) v2.(n) cuniv in + let cuniv = ccnv env CONV l2r infos lft1 lft2 v1.(n) v2.(n) cuniv in fold (n+1) cuniv in fold 0 cuniv else raise NotConvertible @@ -573,7 +605,7 @@ and convert_vect l2r infos lft1 lft2 v1 v2 cuniv = let clos_gen_conv trans cv_pb l2r evars env univs t1 t2 = let reds = CClosure.RedFlags.red_add_transparent betaiotazeta trans in let infos = create_clos_infos ~evars reds env in - ccnv cv_pb l2r infos el_id el_id (inject t1) (inject t2) univs + ccnv env cv_pb l2r infos el_id el_id (inject t1) (inject t2) univs let check_eq univs u u' = @@ -610,9 +642,88 @@ let check_convert_instances ~flex u u' univs = if UGraph.check_eq_instances univs u u' then univs else raise NotConvertible +(* general conversion and inference functions *) +let infer_check_conv_inductives + infer_check_convert_instances + infer_check_inductive_instances + cv_pb (mind, ind) u1 sv1 u2 sv2 univs = + match mind.Declarations.mind_universes with + | Declarations.Monomorphic_ind _ | Declarations.Polymorphic_ind _ -> + infer_check_convert_instances ~flex:false u1 u2 univs + | Declarations.Cumulative_ind cumi -> + let num_param_arity = + mind.Declarations.mind_nparams + mind.Declarations.mind_packets.(ind).Declarations.mind_nrealargs + in + if not (num_param_arity = sv1 && num_param_arity = sv2) then + infer_check_convert_instances ~flex:false u1 u2 univs + else + infer_check_inductive_instances cv_pb cumi u1 u2 univs + +let infer_check_conv_constructors + infer_check_convert_instances + infer_check_inductive_instances + (mind, ind, cns) u1 sv1 u2 sv2 univs = + match mind.Declarations.mind_universes with + | Declarations.Monomorphic_ind _ | Declarations.Polymorphic_ind _ -> + infer_check_convert_instances ~flex:false u1 u2 univs + | Declarations.Cumulative_ind cumi -> + let num_cnstr_args = + let nparamsctxt = + mind.Declarations.mind_nparams + mind.Declarations.mind_packets.(ind).Declarations.mind_nrealargs + (* Context.Rel.length mind.Declarations.mind_params_ctxt *) in + nparamsctxt + mind.Declarations.mind_packets.(ind).Declarations.mind_consnrealargs.(cns - 1) + in + if not (num_cnstr_args = sv1 && num_cnstr_args = sv2) then + infer_check_convert_instances ~flex:false u1 u2 univs + else + infer_check_inductive_instances CONV cumi u1 u2 univs + +let check_inductive_instances cv_pb cumi u u' univs = + let length_ind_instance = + Univ.Instance.length + (Univ.AUContext.instance (Univ.ACumulativityInfo.univ_context cumi)) + in + let ind_subtypctx = Univ.ACumulativityInfo.subtyp_context cumi in + if not ((length_ind_instance = Univ.Instance.length u) && + (length_ind_instance = Univ.Instance.length u')) then + anomaly (Pp.str "Invalid inductive subtyping encountered!") + else + let comp_cst = + let comp_subst = (Univ.Instance.append u u') in + Univ.UContext.constraints + (Univ.subst_instance_context comp_subst ind_subtypctx) + in + let comp_cst = + match cv_pb with + CONV -> + let comp_cst' = + let comp_subst = (Univ.Instance.append u' u) in + Univ.UContext.constraints + (Univ.subst_instance_context comp_subst ind_subtypctx) + in + Univ.Constraint.union comp_cst comp_cst' + | CUMUL -> comp_cst + in + if (UGraph.check_constraints comp_cst univs) then univs + else raise NotConvertible + +let check_conv_inductives cv_pb ind u1 sv1 u2 sv2 univs = + infer_check_conv_inductives + check_convert_instances + check_inductive_instances + cv_pb ind u1 sv1 u2 sv2 univs + +let check_conv_constructors cns u1 sv1 u2 sv2 univs = + infer_check_conv_constructors + check_convert_instances + check_inductive_instances + cns u1 sv1 u2 sv2 univs + let checked_universes = { compare = checked_sort_cmp_universes; - compare_instances = check_convert_instances } + compare_instances = check_convert_instances; + conv_inductives = check_conv_inductives; + conv_constructors = check_conv_constructors} let infer_eq (univs, cstrs as cuniv) u u' = if UGraph.check_eq univs u u' then cuniv @@ -647,11 +758,58 @@ let infer_cmp_universes env pb s0 s1 univs = else univs let infer_convert_instances ~flex u u' (univs,cstrs) = - (univs, Univ.enforce_eq_instances u u' cstrs) - + let cstrs' = + if flex then + if UGraph.check_eq_instances univs u u' then cstrs + else raise NotConvertible + else Univ.enforce_eq_instances u u' cstrs + in (univs, cstrs') + +let infer_inductive_instances cv_pb cumi u u' (univs, cstrs) = + let length_ind_instance = + Univ.Instance.length + (Univ.AUContext.instance (Univ.ACumulativityInfo.univ_context cumi)) + in + let ind_subtypctx = Univ.ACumulativityInfo.subtyp_context cumi in + if not ((length_ind_instance = Univ.Instance.length u) && + (length_ind_instance = Univ.Instance.length u')) then + anomaly (Pp.str "Invalid inductive subtyping encountered!") + else + let comp_cst = + let comp_subst = (Univ.Instance.append u u') in + Univ.UContext.constraints + (Univ.subst_instance_context comp_subst ind_subtypctx) + in + let comp_cst = + match cv_pb with + CONV -> + let comp_cst' = + let comp_subst = (Univ.Instance.append u' u) in + Univ.UContext.constraints + (Univ.subst_instance_context comp_subst ind_subtypctx) in + Univ.Constraint.union comp_cst comp_cst' + | CUMUL -> comp_cst + in + (univs, Univ.Constraint.union cstrs comp_cst) + + +let infer_conv_inductives cv_pb ind u1 sv1 u2 sv2 univs = + infer_check_conv_inductives + infer_convert_instances + infer_inductive_instances + cv_pb ind u1 sv1 u2 sv2 univs + +let infer_conv_constructors cns u1 sv1 u2 sv2 univs = + infer_check_conv_constructors + infer_convert_instances + infer_inductive_instances + cns u1 sv1 u2 sv2 univs + let inferred_universes : (UGraph.t * Univ.Constraint.t) universe_compare = { compare = infer_cmp_universes; - compare_instances = infer_convert_instances } + compare_instances = infer_convert_instances; + conv_inductives = infer_conv_inductives; + conv_constructors = infer_conv_constructors} let gen_conv cv_pb l2r reds env evars univs t1 t2 = let b = diff --git a/kernel/reduction.mli b/kernel/reduction.mli index 8a2b2469d6..b6d88c2b9b 100644 --- a/kernel/reduction.mli +++ b/kernel/reduction.mli @@ -36,10 +36,13 @@ type 'a extended_conversion_function = type conv_pb = CONV | CUMUL type 'a universe_compare = - { (* Might raise NotConvertible or UnivInconsistency *) + { (* Might raise NotConvertible *) compare : env -> conv_pb -> sorts -> sorts -> 'a -> 'a; - compare_instances: flex:bool -> - Univ.Instance.t -> Univ.Instance.t -> 'a -> 'a; + compare_instances: flex:bool -> Univ.Instance.t -> Univ.Instance.t -> 'a -> 'a; + conv_inductives : conv_pb -> (Declarations.mutual_inductive_body * int) -> Univ.Instance.t -> int -> + Univ.Instance.t -> int -> 'a -> 'a; + conv_constructors : (Declarations.mutual_inductive_body * int * int) -> + Univ.Instance.t -> int -> Univ.Instance.t -> int -> 'a -> 'a; } type 'a universe_state = 'a * 'a universe_compare diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml index f5e8e86530..946222ef2f 100644 --- a/kernel/safe_typing.ml +++ b/kernel/safe_typing.ml @@ -237,20 +237,29 @@ let private_con_of_scheme ~kind env cl = let universes_of_private eff = let open Declarations in - List.fold_left (fun acc { Entries.eff } -> - match eff with - | Entries.SEscheme (l,s) -> - List.fold_left (fun acc (_,_,cb,c) -> - let acc = match c with - | `Nothing -> acc - | `Opaque (_, ctx) -> ctx :: acc in - if cb.const_polymorphic then acc - else (Univ.ContextSet.of_context cb.const_universes) :: acc) - acc l - | Entries.SEsubproof (c, cb, e) -> - if cb.const_polymorphic then acc - else Univ.ContextSet.of_context cb.const_universes :: acc) - [] (Term_typing.uniq_seff eff) + List.fold_left + (fun acc { Entries.eff } -> + match eff with + | Entries.SEscheme (l,s) -> + List.fold_left + (fun acc (_,_,cb,c) -> + let acc = match c with + | `Nothing -> acc + | `Opaque (_, ctx) -> ctx :: acc + in + match cb.const_universes with + | Monomorphic_const ctx -> + (Univ.ContextSet.of_context ctx) :: acc + | Polymorphic_const _ -> acc + ) + acc l + | Entries.SEsubproof (c, cb, e) -> + match cb.const_universes with + | Monomorphic_const ctx -> + (Univ.ContextSet.of_context ctx) :: acc + | Polymorphic_const _ -> acc + ) + [] (Term_typing.uniq_seff eff) let env_of_safe_env senv = senv.env let env_of_senv = env_of_safe_env @@ -373,7 +382,11 @@ let safe_push_named d env = let push_named_def (id,de) senv = - let c,typ,univs = Term_typing.translate_local_def senv.revstruct senv.env id de in + let c,typ,univs = + match Term_typing.translate_local_def senv.revstruct senv.env id de with + | c, typ, Monomorphic_const ctx -> c, typ, ctx + | _, _, Polymorphic_const _ -> assert false + in let poly = de.Entries.const_entry_polymorphic in let univs = Univ.ContextSet.of_context univs in let c, univs = match c with @@ -410,26 +423,28 @@ let labels_of_mib mib = get () let globalize_constant_universes env cb = - if cb.const_polymorphic then - [Now (true, Univ.ContextSet.empty)] - else - let cstrs = Univ.ContextSet.of_context cb.const_universes in - Now (false, cstrs) :: - (match cb.const_body with - | (Undef _ | Def _) -> [] - | OpaqueDef lc -> - match Opaqueproof.get_constraints (Environ.opaque_tables env) lc with - | None -> [] - | Some fc -> + match cb.const_universes with + | Monomorphic_const ctx -> + let cstrs = Univ.ContextSet.of_context ctx in + Now (false, cstrs) :: + (match cb.const_body with + | (Undef _ | Def _) -> [] + | OpaqueDef lc -> + match Opaqueproof.get_constraints (Environ.opaque_tables env) lc with + | None -> [] + | Some fc -> match Future.peek_val fc with - | None -> [Later fc] - | Some c -> [Now (false, c)]) + | None -> [Later fc] + | Some c -> [Now (false, c)]) + | Polymorphic_const _ -> + [Now (true, Univ.ContextSet.empty)] let globalize_mind_universes mb = - if mb.mind_polymorphic then - [Now (true, Univ.ContextSet.empty)] - else - [Now (false, Univ.ContextSet.of_context mb.mind_universes)] + match mb.mind_universes with + | Monomorphic_ind ctx -> + [Now (false, Univ.ContextSet.of_context ctx)] + | Polymorphic_ind _ -> [Now (true, Univ.ContextSet.empty)] + | Cumulative_ind _ -> [Now (true, Univ.ContextSet.empty)] let constraints_of_sfb env sfb = match sfb with diff --git a/kernel/subtyping.ml b/kernel/subtyping.ml index f779f68be4..1bd9d6e495 100644 --- a/kernel/subtyping.ml +++ b/kernel/subtyping.ml @@ -90,6 +90,7 @@ let check_conv_error error why cst poly u f env a1 a2 = else error (IncompatiblePolymorphism (env, a1, a2)) else Constraint.union cst cst' with NotConvertible -> error why + | Univ.UniverseInconsistency e -> error (IncompatibleUniverses e) (* for now we do not allow reorderings *) @@ -103,15 +104,21 @@ let check_inductive cst env mp1 l info1 mp2 mib2 spec2 subst1 subst2 reso1 reso2 | IndType ((_,0), mib) -> Declareops.subst_mind_body subst1 mib | _ -> error (InductiveFieldExpected mib2) in - let poly = - if not (mib1.mind_polymorphic == mib2.mind_polymorphic) then - error (PolymorphicStatusExpected mib2.mind_polymorphic) - else mib2.mind_polymorphic - in - let u = - if poly then - CErrors.user_err Pp.(str "Checking of subtyping of polymorphic inductive types not implemented") - else Instance.empty + let u = + let process inst inst' = + if Univ.Instance.equal inst inst' then inst else error IncompatibleInstances + in + match mib1.mind_universes, mib2.mind_universes with + | Monomorphic_ind _, Monomorphic_ind _ -> Univ.Instance.empty + | Polymorphic_ind auctx, Polymorphic_ind auctx' -> + process + (Univ.AUContext.instance auctx) (Univ.AUContext.instance auctx') + | Cumulative_ind cumi, Cumulative_ind cumi' -> + process + (Univ.AUContext.instance (Univ.ACumulativityInfo.univ_context cumi)) + (Univ.AUContext.instance (Univ.ACumulativityInfo.univ_context cumi')) + | _ -> error + (CumulativeStatusExpected (Declareops.inductive_is_cumulative mib2)) in let mib2 = Declareops.subst_mind_body subst2 mib2 in let check_inductive_type cst name env t1 t2 = @@ -147,7 +154,7 @@ let check_inductive cst env mp1 l info1 mp2 mib2 spec2 subst1 subst2 reso1 reso2 error (NotConvertibleInductiveField name) | _ -> (s1, s2) in check_conv (NotConvertibleInductiveField name) - cst poly u infer_conv_leq env (mkArity (ctx1,s1)) (mkArity (ctx2,s2)) + cst (inductive_is_polymorphic mib1) u infer_conv_leq env (mkArity (ctx1,s1)) (mkArity (ctx2,s2)) in let check_packet cst p1 p2 = @@ -175,7 +182,7 @@ let check_inductive cst env mp1 l info1 mp2 mib2 spec2 subst1 subst2 reso1 reso2 let check_cons_types i cst p1 p2 = Array.fold_left3 (fun cst id t1 t2 -> check_conv (NotConvertibleConstructorField id) cst - poly u infer_conv env t1 t2) + (inductive_is_polymorphic mib1) u infer_conv env t1 t2) cst p2.mind_consnames (arities_of_specif (mind,u) (mib1,p1)) @@ -292,37 +299,42 @@ let check_constant cst env mp1 l info1 cb2 spec2 subst1 subst2 = let cb2 = Declareops.subst_const_body subst2 cb2 in (* Start by checking universes *) let poly = - if not (cb1.const_polymorphic == cb2.const_polymorphic) then - error (PolymorphicStatusExpected cb2.const_polymorphic) - else cb2.const_polymorphic + if not (Declareops.constant_is_polymorphic cb1 + == Declareops.constant_is_polymorphic cb2) then + error (PolymorphicStatusExpected (Declareops.constant_is_polymorphic cb2)) + else Declareops.constant_is_polymorphic cb2 in - let cst', env', u = - if poly then - let ctx1 = Univ.instantiate_univ_context cb1.const_universes in - let ctx2 = Univ.instantiate_univ_context cb2.const_universes in - let inst1, ctx1 = Univ.UContext.dest ctx1 in - let inst2, ctx2 = Univ.UContext.dest ctx2 in + let cst', env', u = + match cb1.const_universes, cb2.const_universes with + | Monomorphic_const _, Monomorphic_const _ -> + cst, env, Univ.Instance.empty + | Polymorphic_const auctx1, Polymorphic_const auctx2 -> + begin + let ctx1 = Univ.instantiate_univ_context auctx1 in + let ctx2 = Univ.instantiate_univ_context auctx2 in + let inst1, ctx1 = Univ.UContext.dest ctx1 in + let inst2, ctx2 = Univ.UContext.dest ctx2 in if not (Univ.Instance.length inst1 == Univ.Instance.length inst2) then error IncompatibleInstances else let cstrs = Univ.enforce_eq_instances inst1 inst2 cst in let cstrs = Univ.Constraint.union cstrs ctx2 in - try - (* The environment with the expected universes plus equality - of the body instances with the expected instance *) - let ctxi = Univ.Instance.append inst1 inst2 in - let ctx = Univ.UContext.make (ctxi, cstrs) in - let env = Environ.push_context ctx env in - (* Check that the given definition does not add any constraint over - the expected ones, so that it can be used in place of - the original. *) - if UGraph.check_constraints ctx1 (Environ.universes env) then - cstrs, env, inst2 - else error (IncompatibleConstraints ctx1) - with Univ.UniverseInconsistency incon -> - error (IncompatibleUniverses incon) - else - cst, env, Univ.Instance.empty + try + (* The environment with the expected universes plus equality + of the body instances with the expected instance *) + let ctxi = Univ.Instance.append inst1 inst2 in + let ctx = Univ.UContext.make (ctxi, cstrs) in + let env = Environ.push_context ctx env in + (* Check that the given definition does not add any constraint over + the expected ones, so that it can be used in place of + the original. *) + if UGraph.check_constraints ctx1 (Environ.universes env) then + cstrs, env, inst2 + else error (IncompatibleConstraints ctx1) + with Univ.UniverseInconsistency incon -> + error (IncompatibleUniverses incon) + end + | _ -> assert false in (* Now check types *) let typ1 = Typeops.type_of_constant_type env' cb1.const_type in @@ -353,7 +365,7 @@ let check_constant cst env mp1 l info1 cb2 spec2 subst1 subst2 = "name.")); let () = assert (List.is_empty mind1.mind_hyps && List.is_empty cb2.const_hyps) in if Declareops.constant_has_body cb2 then error DefinitionFieldExpected; - let u1 = inductive_instance mind1 in + let u1 = inductive_polymorphic_instance mind1 in let arity1,cst1 = constrained_type_of_inductive env ((mind1,mind1.mind_packets.(i)),u1) in let cst2 = @@ -370,7 +382,7 @@ let check_constant cst env mp1 l info1 cb2 spec2 subst1 subst2 = "name.")); let () = assert (List.is_empty mind1.mind_hyps && List.is_empty cb2.const_hyps) in if Declareops.constant_has_body cb2 then error DefinitionFieldExpected; - let u1 = inductive_instance mind1 in + let u1 = inductive_polymorphic_instance mind1 in let ty1,cst1 = constrained_type_of_constructor (cstr,u1) (mind1,mind1.mind_packets.(i)) in let cst2 = Declareops.constraints_of_constant (Environ.opaque_tables env) cb2 in diff --git a/kernel/term_typing.ml b/kernel/term_typing.ml index eeb9c421a1..5370bcea43 100644 --- a/kernel/term_typing.ml +++ b/kernel/term_typing.ml @@ -121,18 +121,19 @@ let inline_side_effects env body ctx side_eff = | OpaqueDef _, `Opaque (b,_) -> (b, true) | _ -> assert false in - if cb.const_polymorphic then - (** Inline the term to emulate universe polymorphism *) - let data = (Univ.UContext.instance cb.const_universes, b) in - let subst = Cmap_env.add c (Inl data) subst in - (subst, var, ctx, args) - else + match cb.const_universes with + | Monomorphic_const cnstctx -> (** Abstract over the term at the top of the proof *) let ty = Typeops.type_of_constant_type env cb.const_type in let subst = Cmap_env.add c (Inr var) subst in - let univs = Univ.ContextSet.of_context cb.const_universes in + let univs = Univ.ContextSet.of_context cnstctx in let ctx = Univ.ContextSet.union ctx univs in (subst, var + 1, ctx, (cname c, b, ty, opaque) :: args) + | Polymorphic_const auctx -> + (** Inline the term to emulate universe polymorphism *) + let data = (Univ.AUContext.instance auctx, b) in + let subst = Cmap_env.add c (Inl data) subst in + (subst, var, ctx, args) in let (subst, len, ctx, args) = List.fold_left fold (Cmap_env.empty, 1, ctx, []) side_eff in (** Third step: inline the definitions *) @@ -225,16 +226,25 @@ let feedback_completion_typecheck = Option.iter (fun state_id -> feedback ~id:state_id Feedback.Complete) +let abstract_constant_universes abstract uctx = + if not abstract then + Univ.empty_level_subst, Monomorphic_const uctx + else + let sbst, auctx = Univ.abstract_universes uctx in + sbst, Polymorphic_const auctx + let infer_declaration ~trust env kn dcl = match dcl with | ParameterEntry (ctx,poly,(t,uctx),nl) -> let env = push_context ~strict:(not poly) uctx env in let j = infer env t in let abstract = poly && not (Option.is_empty kn) in - let usubst, univs = Univ.abstract_universes abstract uctx in + let usubst, univs = + abstract_constant_universes abstract uctx + in let c = Typeops.assumption_of_judgment env j in let t = hcons_constr (Vars.subst_univs_level_constr usubst c) in - Undef nl, RegularArity t, None, poly, univs, false, ctx + Undef nl, RegularArity t, None, univs, false, ctx (** Definition [c] is opaque (Qed), non polymorphic and with a specified type, so we delay the typing and hash consing of its body. @@ -264,9 +274,9 @@ let infer_declaration ~trust env kn dcl = feedback_completion_typecheck feedback_id; c, uctx) in let def = OpaqueDef (Opaqueproof.create proofterm) in - def, RegularArity typ, None, c.const_entry_polymorphic, - c.const_entry_universes, - c.const_entry_inline_code, c.const_entry_secctx + def, RegularArity typ, None, + (Monomorphic_const c.const_entry_universes), + c.const_entry_inline_code, c.const_entry_secctx (** Other definitions have to be processed immediately. *) | DefinitionEntry c -> @@ -279,7 +289,8 @@ let infer_declaration ~trust env kn dcl = let env = push_context_set ~strict:(not c.const_entry_polymorphic) ctx env in let abstract = c.const_entry_polymorphic && not (Option.is_empty kn) in let usubst, univs = - Univ.abstract_universes abstract (Univ.ContextSet.to_context ctx) in + abstract_constant_universes abstract (Univ.ContextSet.to_context ctx) + in let j = infer env body in let typ = match typ with | None -> @@ -298,8 +309,7 @@ let infer_declaration ~trust env kn dcl = else Def (Mod_subst.from_val def) in feedback_completion_typecheck feedback_id; - def, typ, None, c.const_entry_polymorphic, - univs, c.const_entry_inline_code, c.const_entry_secctx + def, typ, None, univs, c.const_entry_inline_code, c.const_entry_secctx | ProjectionEntry {proj_entry_ind = ind; proj_entry_arg = i} -> let mib, _ = Inductive.lookup_mind_specif env (ind,0) in @@ -311,9 +321,16 @@ let infer_declaration ~trust env kn dcl = else assert false | _ -> assert false in + let univs = + match mib.mind_universes with + | Monomorphic_ind ctx -> Monomorphic_const ctx + | Polymorphic_ind auctx -> Polymorphic_const auctx + | Cumulative_ind acumi -> + Polymorphic_const (Univ.ACumulativityInfo.univ_context acumi) + in let term, typ = pb.proj_eta in Def (Mod_subst.from_val (hcons_constr term)), RegularArity typ, Some pb, - mib.mind_polymorphic, mib.mind_universes, false, None + univs, false, None let global_vars_set_constant_type env = function | RegularArity t -> global_vars_set env t @@ -337,18 +354,25 @@ let record_aux env s_ty s_bo suggested_expr = let suggest_proof_using = ref (fun _ _ _ _ _ -> "") let set_suggest_proof_using f = suggest_proof_using := f -let build_constant_declaration kn env (def,typ,proj,poly,univs,inline_code,ctx) = +let build_constant_declaration kn env (def,typ,proj,univs,inline_code,ctx) = let check declared inferred = let mk_set l = List.fold_right Id.Set.add (List.map NamedDecl.get_id l) Id.Set.empty in let inferred_set, declared_set = mk_set inferred, mk_set declared in if not (Id.Set.subset inferred_set declared_set) then let l = Id.Set.elements (Idset.diff inferred_set declared_set) in let n = List.length l in - user_err (Pp.(str "The following section " ++ - str (String.plural n "variable") ++ - str " " ++ str (String.conjugate_verb_to_be n) ++ - str " used but not declared:" ++ - fnl () ++ pr_sequence Id.print (List.rev l) ++ str ".")) in + let declared_vars = Pp.pr_sequence Id.print (Idset.elements declared_set) in + let inferred_vars = Pp.pr_sequence Id.print (Idset.elements inferred_set) in + let missing_vars = Pp.pr_sequence Id.print (List.rev l) in + user_err Pp.(prlist str + ["The following section "; (String.plural n "variable"); " "; + (String.conjugate_verb_to_be n); " used but not declared:"] ++ fnl () ++ + missing_vars ++ str "." ++ fnl () ++ fnl () ++ + str "You can either update your proof to not depend on " ++ missing_vars ++ + str ", or you can update your Proof line from" ++ fnl () ++ + str "Proof using " ++ declared_vars ++ fnl () ++ + str "to" ++ fnl () ++ + str "Proof using " ++ inferred_vars) in let sort evn l = List.filter (fun decl -> let id = NamedDecl.get_id decl in @@ -402,9 +426,8 @@ let build_constant_declaration kn env (def,typ,proj,poly,univs,inline_code,ctx) check declared inferred) lc) in let tps = let res = - let comp_univs = if poly then Some univs else None in match proj with - | None -> compile_constant_body env comp_univs def + | None -> compile_constant_body env univs def | Some pb -> (* The compilation of primitive projections is a bit tricky, because they refer to themselves (the body of p looks like fun c => @@ -418,14 +441,13 @@ let build_constant_declaration kn env (def,typ,proj,poly,univs,inline_code,ctx) const_type = typ; const_proj = proj; const_body_code = None; - const_polymorphic = poly; const_universes = univs; const_inline_code = inline_code; const_typing_flags = Environ.typing_flags env; } in let env = add_constant kn cb env in - compile_constant_body env comp_univs def + compile_constant_body env univs def in Option.map Cemitcodes.from_val res in { const_hyps = hyps; @@ -433,7 +455,6 @@ let build_constant_declaration kn env (def,typ,proj,poly,univs,inline_code,ctx) const_type = typ; const_proj = proj; const_body_code = tps; - const_polymorphic = poly; const_universes = univs; const_inline_code = inline_code; const_typing_flags = Environ.typing_flags env } @@ -445,6 +466,12 @@ let translate_constant mb env kn ce = (infer_declaration ~trust:mb env (Some kn) ce) let constant_entry_of_side_effect cb u = + let poly, univs = + match cb.const_universes with + | Monomorphic_const ctx -> false, ctx + | Polymorphic_const auctx -> + true, Univ.instantiate_univ_context auctx + in let pt = match cb.const_body, u with | OpaqueDef _, `Opaque (b, c) -> b, c @@ -456,8 +483,8 @@ let constant_entry_of_side_effect cb u = const_entry_feedback = None; const_entry_type = (match cb.const_type with RegularArity t -> Some t | _ -> None); - const_entry_polymorphic = cb.const_polymorphic; - const_entry_universes = cb.const_universes; + const_entry_polymorphic = poly; + const_entry_universes = univs; const_entry_opaque = Declareops.is_opaque cb; const_entry_inline_code = cb.const_inline_code } ;; @@ -501,16 +528,23 @@ let export_side_effects mb env ce = let trusted = check_signatures mb signatures in let push_seff env = function | kn, cb, `Nothing, _ -> - let env = Environ.add_constant kn cb env in - if not cb.const_polymorphic then - Environ.push_context ~strict:true cb.const_universes env - else env - | kn, cb, `Opaque(_, ctx), _ -> - let env = Environ.add_constant kn cb env in - if not cb.const_polymorphic then - let env = Environ.push_context ~strict:true cb.const_universes env in - Environ.push_context_set ~strict:true ctx env - else env in + begin + let env = Environ.add_constant kn cb env in + match cb.const_universes with + | Monomorphic_const ctx -> + Environ.push_context ~strict:true ctx env + | Polymorphic_const _ -> env + end + | kn, cb, `Opaque(_, ctx), _ -> + begin + let env = Environ.add_constant kn cb env in + match cb.const_universes with + | Monomorphic_const cstctx -> + let env = Environ.push_context ~strict:true cstctx env in + Environ.push_context_set ~strict:true ctx env + | Polymorphic_const _ -> env + end + in let rec translate_seff sl seff acc env = match sl, seff with | _, [] -> List.rev acc, ce @@ -546,7 +580,7 @@ let translate_recipe env kn r = build_constant_declaration kn env (Cooking.cook_constant ~hcons env r) let translate_local_def mb env id centry = - let def,typ,proj,poly,univs,inline_code,ctx = + let def,typ,proj,univs,inline_code,ctx = infer_declaration ~trust:mb env None (DefinitionEntry centry) in let typ = type_of_constant_type env typ in if ctx = None && !Flags.compilation_mode = Flags.BuildVo then begin diff --git a/kernel/typeops.ml b/kernel/typeops.ml index 1a07bb2fc6..e08f3362db 100644 --- a/kernel/typeops.ml +++ b/kernel/typeops.ml @@ -555,7 +555,7 @@ let type_of_projection_constant env (p,u) = let cb = lookup_constant cst env in match cb.const_proj with | Some pb -> - if cb.const_polymorphic then + if Declareops.constant_is_polymorphic cb then Vars.subst_instance_constr u pb.proj_type else pb.proj_type | None -> raise (Invalid_argument "type_of_projection: not a projection") diff --git a/kernel/univ.ml b/kernel/univ.ml index d53dd8e733..8cbb20a051 100644 --- a/kernel/univ.ml +++ b/kernel/univ.ml @@ -725,8 +725,11 @@ struct pp_std ++ prl u1 ++ pr_constraint_type op ++ prl u2 ++ fnl () ) c (str "") + let universes_of c = + fold (fun (u1, op, u2) unvs -> LSet.add u2 (LSet.add u1 unvs)) c LSet.empty end +let universes_of_constraints = Constraint.universes_of let empty_constraint = Constraint.empty let union_constraint = Constraint.union let eq_constraint = Constraint.equal @@ -1028,6 +1031,82 @@ end type universe_context = UContext.t let hcons_universe_context = UContext.hcons +module AUContext = UContext + +type abstract_universe_context = AUContext.t +let hcons_abstract_universe_context = AUContext.hcons + +(** Universe info for cumulative inductive types: + A context of universe levels + with universe constraints, representing local universe variables + and constraints, together with a context of universe levels with + universe constraints, representing conditions for subtyping used + for inductive types. + + This data structure maintains the invariant that the context for + subtyping constraints is exactly twice as big as the context for + universe constraints. *) +module CumulativityInfo = +struct + type t = universe_context * universe_context + + let make x = + if (Instance.length (UContext.instance (snd x))) = + (Instance.length (UContext.instance (fst x))) * 2 then x + else anomaly (Pp.str "Invalid subtyping information encountered!") + + let empty = (UContext.empty, UContext.empty) + let is_empty (univcst, subtypcst) = UContext.is_empty univcst && UContext.is_empty subtypcst + + let halve_context ctx = + let len = Array.length (Instance.to_array ctx) in + let halflen = len / 2 in + (Instance.of_array (Array.sub (Instance.to_array ctx) 0 halflen), + Instance.of_array (Array.sub (Instance.to_array ctx) halflen halflen)) + + let pr prl (univcst, subtypcst) = + if UContext.is_empty univcst then mt() else + let (ctx, ctx') = halve_context (UContext.instance subtypcst) in + (UContext.pr prl univcst) ++ fnl () ++ fnl () ++ + h 0 (str "~@{" ++ Instance.pr prl ctx ++ str "} <= ~@{" ++ Instance.pr prl ctx' ++ str "} iff ") + ++ fnl () ++ h 0 (v 0 (Constraint.pr prl (UContext.constraints subtypcst))) + + let hcons (univcst, subtypcst) = + (UContext.hcons univcst, UContext.hcons subtypcst) + + let univ_context (univcst, subtypcst) = univcst + let subtyp_context (univcst, subtypcst) = subtypcst + + let create_trivial_subtyping ctx ctx' = + CArray.fold_left_i + (fun i cst l -> Constraint.add (l, Eq, Array.get ctx' i) cst) + Constraint.empty (Instance.to_array ctx) + + (** This function takes a universe context representing constraints + of an inductive and a Instance.t of fresh universe names for the + subtyping (with the same length as the context in the given + universe context) and produces a UInfoInd.t that with the + trivial subtyping relation. *) + let from_universe_context univcst freshunivs = + let inst = (UContext.instance univcst) in + assert (Instance.length freshunivs = Instance.length inst); + (univcst, UContext.make (Instance.append inst freshunivs, + create_trivial_subtyping inst freshunivs)) + + let subtyping_susbst (univcst, subtypcst) = + let (ctx, ctx') = (halve_context (UContext.instance subtypcst))in + Array.fold_left2 (fun subst l1 l2 -> LMap.add l1 l2 subst) LMap.empty ctx ctx' + +end + +type cumulativity_info = CumulativityInfo.t +let hcons_cumulativity_info = CumulativityInfo.hcons + +module ACumulativityInfo = CumulativityInfo + +type abstract_cumulativity_info = ACumulativityInfo.t +let hcons_abstract_cumulativity_info = ACumulativityInfo.hcons + (** A set of universes with universe constraints. We linearize the set to a list after typechecking. Beware, representation could change. @@ -1132,6 +1211,9 @@ let subst_univs_level_constraints subst csts = (fun c -> Option.fold_right Constraint.add (subst_univs_level_constraint subst c)) csts Constraint.empty +let subst_univs_level_abstract_universe_context subst (inst, csts) = + inst, subst_univs_level_constraints subst csts + (** With level to universe substitutions. *) type universe_subst_fn = universe_level -> universe @@ -1203,8 +1285,9 @@ let subst_instance_constraints s csts = let instantiate_univ_context (ctx, csts) = (ctx, subst_instance_constraints ctx csts) -let instantiate_univ_constraints u (_, csts) = - subst_instance_constraints u csts +(** Substitute instance inst for ctx in universe constraints and subtyping constraints *) +let instantiate_cumulativity_info (univcst, subtpcst) = + (instantiate_univ_context univcst, instantiate_univ_context subtpcst) let make_instance_subst i = let arr = Instance.to_array i in @@ -1218,16 +1301,22 @@ let make_inverse_instance_subst i = LMap.add (Level.var i) l acc) LMap.empty arr -let abstract_universes poly ctx = +let make_abstract_instance (ctx, _) = + Array.mapi (fun i l -> Level.var i) ctx + +let abstract_universes ctx = let instance = UContext.instance ctx in - if poly then - let subst = make_instance_subst instance in - let cstrs = subst_univs_level_constraints subst - (UContext.constraints ctx) - in - let ctx = UContext.make (instance, cstrs) in - subst, ctx - else empty_level_subst, ctx + let subst = make_instance_subst instance in + let cstrs = subst_univs_level_constraints subst + (UContext.constraints ctx) + in + let ctx = UContext.make (instance, cstrs) in + subst, ctx + +let abstract_cumulativity_info (univcst, substcst) = + let instance, univcst = abstract_universes univcst in + let _, substcst = abstract_universes substcst in + (instance, (univcst, substcst)) (** Pretty-printing *) @@ -1235,6 +1324,12 @@ let pr_constraints prl = Constraint.pr prl let pr_universe_context = UContext.pr +let pr_cumulativity_info = CumulativityInfo.pr + +let pr_abstract_universe_context = AUContext.pr + +let pr_abstract_cumulativity_info = ACumulativityInfo.pr + let pr_universe_context_set = ContextSet.pr let pr_universe_subst = @@ -1290,3 +1385,12 @@ let subst_instance_constraints = let key = Profile.declare_profile "subst_instance_constraints" in Profile.profile2 key subst_instance_constraints else subst_instance_constraints + +let subst_instance_context = + let subst_instance_context_body inst (inner_inst, inner_constr) = + (inner_inst, subst_instance_constraints inst inner_constr) + in + if Flags.profile then + let key = Profile.declare_profile "subst_instance_constraints" in + Profile.profile2 key subst_instance_context_body + else subst_instance_context_body diff --git a/kernel/univ.mli b/kernel/univ.mli index 1ccdebd501..ecc72701d4 100644 --- a/kernel/univ.mli +++ b/kernel/univ.mli @@ -315,6 +315,67 @@ end type universe_context = UContext.t +module AUContext : +sig + type t + + val empty : t + + val instance : t -> Instance.t + + val size : t -> int + + (** Keeps the order of the instances *) + val union : t -> t -> t + +end + +type abstract_universe_context = AUContext.t + +(** Universe info for inductive types: A context of universe levels + with universe constraints, representing local universe variables + and constraints, together with a context of universe levels with + universe constraints, representing conditions for subtyping used + for inductive types. + + This data structure maintains the invariant that the context for + subtyping constraints is exactly twice as big as the context for + universe constraints. *) +module CumulativityInfo : +sig + type t + + val make : universe_context * universe_context -> t + + val empty : t + val is_empty : t -> bool + + val univ_context : t -> universe_context + val subtyp_context : t -> universe_context + + (** This function takes a universe context representing constraints + of an inductive and a Instance.t of fresh universe names for the + subtyping (with the same length as the context in the given + universe context) and produces a UInfoInd.t that with the + trivial subtyping relation. *) + val from_universe_context : universe_context -> universe_instance -> t + + val subtyping_susbst : t -> universe_level_subst + +end + +type cumulativity_info = CumulativityInfo.t + +module ACumulativityInfo : +sig + type t + + val univ_context : t -> abstract_universe_context + val subtyp_context : t -> abstract_universe_context +end + +type abstract_cumulativity_info = ACumulativityInfo.t + (** Universe contexts (as sets) *) module ContextSet : @@ -365,6 +426,8 @@ val is_empty_level_subst : universe_level_subst -> bool val subst_univs_level_level : universe_level_subst -> universe_level -> universe_level val subst_univs_level_universe : universe_level_subst -> universe -> universe val subst_univs_level_constraints : universe_level_subst -> constraints -> constraints +val subst_univs_level_abstract_universe_context : + universe_level_subst -> abstract_universe_context -> abstract_universe_context val subst_univs_level_instance : universe_level_subst -> universe_instance -> universe_instance (** Level to universe substitutions. *) @@ -379,23 +442,31 @@ val subst_univs_constraints : universe_subst_fn -> constraints -> constraints (** Substitution of instances *) val subst_instance_instance : universe_instance -> universe_instance -> universe_instance val subst_instance_universe : universe_instance -> universe -> universe -val subst_instance_constraints : universe_instance -> constraints -> constraints +val subst_instance_context : universe_instance -> abstract_universe_context -> universe_context val make_instance_subst : universe_instance -> universe_level_subst val make_inverse_instance_subst : universe_instance -> universe_level_subst -val abstract_universes : bool -> universe_context -> universe_level_subst * universe_context +val abstract_universes : universe_context -> universe_level_subst * abstract_universe_context + +val abstract_cumulativity_info : cumulativity_info -> universe_level_subst * abstract_cumulativity_info + +val make_abstract_instance : abstract_universe_context -> universe_instance (** Get the instantiated graph. *) -val instantiate_univ_context : universe_context -> universe_context +val instantiate_univ_context : abstract_universe_context -> universe_context -val instantiate_univ_constraints : universe_instance -> universe_context -> constraints +(** Get the instantiated graphs for both universe constraints and subtyping constraints. *) +val instantiate_cumulativity_info : abstract_cumulativity_info -> cumulativity_info (** {6 Pretty-printing of universes. } *) val pr_constraint_type : constraint_type -> Pp.std_ppcmds val pr_constraints : (Level.t -> Pp.std_ppcmds) -> constraints -> Pp.std_ppcmds val pr_universe_context : (Level.t -> Pp.std_ppcmds) -> universe_context -> Pp.std_ppcmds +val pr_cumulativity_info : (Level.t -> Pp.std_ppcmds) -> cumulativity_info -> Pp.std_ppcmds +val pr_abstract_universe_context : (Level.t -> Pp.std_ppcmds) -> abstract_universe_context -> Pp.std_ppcmds +val pr_abstract_cumulativity_info : (Level.t -> Pp.std_ppcmds) -> abstract_cumulativity_info -> Pp.std_ppcmds val pr_universe_context_set : (Level.t -> Pp.std_ppcmds) -> universe_context_set -> Pp.std_ppcmds val explain_universe_inconsistency : (Level.t -> Pp.std_ppcmds) -> univ_inconsistency -> Pp.std_ppcmds @@ -409,7 +480,10 @@ val hcons_univ : universe -> universe val hcons_constraints : constraints -> constraints val hcons_universe_set : universe_set -> universe_set val hcons_universe_context : universe_context -> universe_context +val hcons_abstract_universe_context : abstract_universe_context -> abstract_universe_context val hcons_universe_context_set : universe_context_set -> universe_context_set +val hcons_cumulativity_info : cumulativity_info -> cumulativity_info +val hcons_abstract_cumulativity_info : abstract_cumulativity_info -> abstract_cumulativity_info (******) @@ -419,3 +493,6 @@ val eq_levels : universe_level -> universe_level -> bool (** deprecated: Equality of formal universe expressions. *) val equal_universes : universe -> universe -> bool + +(** Universes of constraints *) +val universes_of_constraints : constraints -> universe_set diff --git a/kernel/vars.ml b/kernel/vars.ml index 629de80f7c..baf8fa31f6 100644 --- a/kernel/vars.ml +++ b/kernel/vars.ml @@ -319,35 +319,33 @@ let subst_instance_constr subst c = if Univ.Instance.is_empty subst then c else let f u = Univ.subst_instance_instance subst u in - let changed = ref false in - let rec aux t = + let rec aux t = match kind t with - | Const (c, u) -> - if Univ.Instance.is_empty u then t - else - let u' = f u in - if u' == u then t - else (changed := true; mkConstU (c, u')) + | Const (c, u) -> + if Univ.Instance.is_empty u then t + else + let u' = f u in + if u' == u then t + else (mkConstU (c, u')) | Ind (i, u) -> - if Univ.Instance.is_empty u then t - else - let u' = f u in - if u' == u then t - else (changed := true; mkIndU (i, u')) + if Univ.Instance.is_empty u then t + else + let u' = f u in + if u' == u then t + else (mkIndU (i, u')) | Construct (c, u) -> - if Univ.Instance.is_empty u then t - else - let u' = f u in - if u' == u then t - else (changed := true; mkConstructU (c, u')) - | Sort (Sorts.Type u) -> + if Univ.Instance.is_empty u then t + else + let u' = f u in + if u' == u then t + else (mkConstructU (c, u')) + | Sort (Sorts.Type u) -> let u' = Univ.subst_instance_universe subst u in - if u' == u then t else - (changed := true; mkSort (Sorts.sort_of_univ u')) + if u' == u then t else + (mkSort (Sorts.sort_of_univ u')) | _ -> Constr.map aux t in - let c' = aux c in - if !changed then c' else c + aux c (* let substkey = Profile.declare_profile "subst_instance_constr";; *) (* let subst_instance_constr inst c = Profile.profile2 substkey subst_instance_constr inst c;; *) diff --git a/kernel/vconv.ml b/kernel/vconv.ml index 74d956bef0..0e452621c8 100644 --- a/kernel/vconv.ml +++ b/kernel/vconv.ml @@ -88,30 +88,34 @@ and conv_atom env pb k a1 stk1 a2 stk2 cu = (* Pp.(msg_debug (str "conv_atom(" ++ pr_atom a1 ++ str ", " ++ pr_atom a2 ++ str ")")) ; *) match a1, a2 with | Aind ((mi,i) as ind1) , Aind ind2 -> - if eq_ind ind1 ind2 && compare_stack stk1 stk2 - then - if Environ.polymorphic_ind ind1 env - then - let mib = Environ.lookup_mind mi env in - let ulen = Univ.UContext.size mib.Declarations.mind_universes in - match stk1 , stk2 with - | [], [] -> assert (Int.equal ulen 0); cu - | Zapp args1 :: stk1' , Zapp args2 :: stk2' -> - assert (ulen <= nargs args1); - assert (ulen <= nargs args2); - let u1 = Array.init ulen (fun i -> uni_lvl_val (arg args1 i)) in - let u2 = Array.init ulen (fun i -> uni_lvl_val (arg args2 i)) in - let u1 = Univ.Instance.of_array u1 in - let u2 = Univ.Instance.of_array u2 in - let cu = convert_instances ~flex:false u1 u2 cu in - conv_arguments env ~from:ulen k args1 args2 - (conv_stack env k stk1' stk2' cu) - | _, _ -> assert false (* Should not happen if problem is well typed *) - else - conv_stack env k stk1 stk2 cu - else raise NotConvertible + if eq_ind ind1 ind2 && compare_stack stk1 stk2 then + if Environ.polymorphic_ind ind1 env then + let mib = Environ.lookup_mind mi env in + let ulen = + match mib.Declarations.mind_universes with + | Declarations.Monomorphic_ind ctx -> Univ.UContext.size ctx + | Declarations.Polymorphic_ind auctx -> Univ.AUContext.size auctx + | Declarations.Cumulative_ind cumi -> + Univ.AUContext.size (Univ.ACumulativityInfo.univ_context cumi) + in + match stk1 , stk2 with + | [], [] -> assert (Int.equal ulen 0); cu + | Zapp args1 :: stk1' , Zapp args2 :: stk2' -> + assert (ulen <= nargs args1); + assert (ulen <= nargs args2); + let u1 = Array.init ulen (fun i -> uni_lvl_val (arg args1 i)) in + let u2 = Array.init ulen (fun i -> uni_lvl_val (arg args2 i)) in + let u1 = Univ.Instance.of_array u1 in + let u2 = Univ.Instance.of_array u2 in + let cu = convert_instances ~flex:false u1 u2 cu in + conv_arguments env ~from:ulen k args1 args2 + (conv_stack env k stk1' stk2' cu) + | _, _ -> assert false (* Should not happen if problem is well typed *) + else + conv_stack env k stk1 stk2 cu + else raise NotConvertible | Aid ik1, Aid ik2 -> - if Vars.eq_id_key ik1 ik2 && compare_stack stk1 stk2 then + if Vars.eq_id_key ik1 ik2 && compare_stack stk1 stk2 then conv_stack env k stk1 stk2 cu else raise NotConvertible | Atype _ , _ | _, Atype _ -> assert false diff --git a/lib/envars.mli b/lib/envars.mli index edd13447fc..18b7676ce7 100644 --- a/lib/envars.mli +++ b/lib/envars.mli @@ -53,7 +53,7 @@ val coqroot : string the order it gets added to the search path. *) val coqpath : string list -(** [camlbin ()] is the path to the ocamlfind binary. *) +(** [camlfind ()] is the path to the ocamlfind binary. *) val ocamlfind : unit -> string (** [camlp4bin ()] is the path to the camlp4 binary. *) diff --git a/lib/flags.ml b/lib/flags.ml index 6a3b7a4261..46bbba8e55 100644 --- a/lib/flags.ml +++ b/lib/flags.ml @@ -106,35 +106,27 @@ let we_are_parsing = ref false (* Current means no particular compatibility consideration. For correct comparisons, this constructor should remain the last one. *) -type compat_version = V8_2 | V8_3 | V8_4 | V8_5 | V8_6 | Current +type compat_version = VOld | V8_5 | V8_6 | Current let compat_version = ref Current let version_compare v1 v2 = match v1, v2 with -| V8_2, V8_2 -> 0 -| V8_2, (V8_3 | V8_4 | V8_5 | V8_6 | Current) -> -1 -| V8_3, V8_2 -> 1 -| V8_3, V8_3 -> 0 -| V8_3, (V8_4 | V8_5 | V8_6 | Current) -> -1 -| V8_4, (V8_2 | V8_3) -> 1 -| V8_4, V8_4 -> 0 -| V8_4, (V8_5 | V8_6 | Current) -> -1 -| V8_5, (V8_2 | V8_3 | V8_4) -> 1 -| V8_5, V8_5 -> 0 -| V8_5, (V8_6 | Current) -> -1 -| V8_6, (V8_2 | V8_3 | V8_4 | V8_5) -> 1 -| V8_6, V8_6 -> 0 -| V8_6, Current -> -1 -| Current, Current -> 0 -| Current, (V8_2 | V8_3 | V8_4 | V8_5 | V8_6) -> 1 + | VOld, VOld -> 0 + | VOld, _ -> -1 + | _, VOld -> 1 + | V8_5, V8_5 -> 0 + | V8_5, _ -> -1 + | _, V8_5 -> 1 + | V8_6, V8_6 -> 0 + | V8_6, _ -> -1 + | _, V8_6 -> 1 + | Current, Current -> 0 let version_strictly_greater v = version_compare !compat_version v > 0 let version_less_or_equal v = not (version_strictly_greater v) let pr_version = function - | V8_2 -> "8.2" - | V8_3 -> "8.3" - | V8_4 -> "8.4" + | VOld -> "old" | V8_5 -> "8.5" | V8_6 -> "8.6" | Current -> "current" @@ -157,7 +149,7 @@ let is_verbose () = not !quiet let auto_intros = ref true let make_auto_intros flag = auto_intros := flag -let is_auto_intros () = version_strictly_greater V8_2 && !auto_intros +let is_auto_intros () = !auto_intros let universe_polymorphism = ref false let make_universe_polymorphism b = universe_polymorphism := b @@ -171,6 +163,10 @@ let use_polymorphic_flag () = let make_polymorphic_flag b = local_polymorphic_flag := Some b +let inductive_cumulativity = ref false +let make_inductive_cumulativity b = inductive_cumulativity := b +let is_inductive_cumulativity () = !inductive_cumulativity + (** [program_mode] tells that Program mode has been activated, either globally via [Set Program] or locally via the Program command prefix. *) diff --git a/lib/flags.mli b/lib/flags.mli index e2cf09474e..5e78f0a041 100644 --- a/lib/flags.mli +++ b/lib/flags.mli @@ -77,7 +77,7 @@ val raw_print : bool ref (* Univ print flag, never set anywere. Maybe should belong to Univ? *) val univ_print : bool ref -type compat_version = V8_2 | V8_3 | V8_4 | V8_5 | V8_6 | Current +type compat_version = VOld | V8_5 | V8_6 | Current val compat_version : compat_version ref val version_compare : compat_version -> compat_version -> int val version_strictly_greater : compat_version -> bool @@ -119,6 +119,10 @@ val is_universe_polymorphism : unit -> bool val make_polymorphic_flag : bool -> unit val use_polymorphic_flag : unit -> bool +(** Global inductive cumulativity flag. *) +val make_inductive_cumulativity : bool -> unit +val is_inductive_cumulativity : unit -> bool + val warn : bool ref val make_warn : bool -> unit val if_warn : ('a -> unit) -> 'a -> unit diff --git a/lib/pp.mli b/lib/pp.mli index 7a191b01a8..45834dade5 100644 --- a/lib/pp.mli +++ b/lib/pp.mli @@ -13,6 +13,7 @@ (* `Pp.t` or `Pp.std_ppcmds` is the main pretty printing document type *) (* in the Coq system. Documents are composed laying out boxes, and *) (* users can add arbitrary tag metadata that backends are free *) +(* to interpret. *) (* *) (* The datatype has a public view to allow serialization or advanced *) (* uses, however regular users are _strongly_ warned againt its use, *) diff --git a/library/declare.ml b/library/declare.ml index 7d0edbc8b3..db3dbcbd92 100644 --- a/library/declare.ml +++ b/library/declare.ml @@ -158,7 +158,7 @@ let cache_constant ((sp,kn), obj) = assert (eq_constant kn' (constant_of_kn kn)); Nametab.push (Nametab.Until 1) sp (ConstRef (constant_of_kn kn)); let cst = Global.lookup_constant kn' in - add_section_constant cst.const_polymorphic kn' cst.const_hyps; + add_section_constant (Declareops.constant_is_polymorphic cst) kn' cst.const_hyps; Dischargedhypsmap.set_discharged_hyps sp obj.cst_hyps; add_constant_kind (constant_of_kn kn) obj.cst_kind @@ -325,7 +325,7 @@ let cache_inductive ((sp,kn),(dhyps,mie)) = let kn' = Global.add_mind dir id mie in assert (eq_mind kn' (mind_of_kn kn)); let mind = Global.lookup_mind kn' in - add_section_kn mind.mind_polymorphic kn' mind.mind_hyps; + add_section_kn (Declareops.inductive_is_polymorphic mind) kn' mind.mind_hyps; Dischargedhypsmap.set_discharged_hyps sp dhyps; List.iter (fun (sp, ref) -> Nametab.push (Nametab.Until 1) sp ref) names @@ -351,11 +351,27 @@ let dummy_inductive_entry (_,m) = ([],{ mind_entry_record = None; mind_entry_finite = Decl_kinds.BiFinite; mind_entry_inds = List.map dummy_one_inductive_entry m.mind_entry_inds; - mind_entry_polymorphic = false; - mind_entry_universes = Univ.UContext.empty; + mind_entry_universes = Monomorphic_ind_entry Univ.UContext.empty; mind_entry_private = None; }) +(* reinfer subtyping constraints for inductive after section is dischared. *) +let infer_inductive_subtyping (pth, mind_ent) = + match mind_ent.mind_entry_universes with + | Monomorphic_ind_entry _ | Polymorphic_ind_entry _ -> + (pth, mind_ent) + | Cumulative_ind_entry cumi -> + begin + let env = Global.env () in + let env' = + Environ.push_context + (Univ.CumulativityInfo.univ_context cumi) env + in + (* let (env'', typed_params) = Typeops.infer_local_decls env' (mind_ent.mind_entry_params) in *) + let evd = Evd.from_env env' in + (pth, Inductiveops.infer_inductive_subtyping env' evd mind_ent) + end + type inductive_obj = Dischargedhypsmap.discharged_hyps * mutual_inductive_entry let inInductive : inductive_obj -> obj = @@ -365,7 +381,8 @@ let inInductive : inductive_obj -> obj = open_function = open_inductive; classify_function = (fun a -> Substitute (dummy_inductive_entry a)); subst_function = ident_subst_function; - discharge_function = discharge_inductive } + discharge_function = discharge_inductive; + rebuild_function = infer_inductive_subtyping } let declare_projections mind = let spec,_ = Inductive.lookup_mind_specif (Global.env ()) (mind,0) in diff --git a/library/declaremods.ml b/library/declaremods.ml index c98d4a7f31..187b749b87 100644 --- a/library/declaremods.ml +++ b/library/declaremods.ml @@ -589,7 +589,6 @@ let start_module interp_modast export id args res fs = openmod_info := { cur_typ = res_entry_o; cur_typs = subtyps }; let prefix = Lib.start_module export id mp fs in Nametab.push_dir (Nametab.Until 1) (fst prefix) (DirOpenModule prefix); - Lib.add_frozen_state (); if_xml (Hook.get f_xml_start_module) mp; mp @@ -629,7 +628,6 @@ let end_module () = assert (eq_full_path (fst newoname) (fst oldoname)); assert (ModPath.equal (mp_of_kn (snd newoname)) mp); - Lib.add_frozen_state () (* to prevent recaching *); if_xml (Hook.get f_xml_end_module) mp; mp @@ -701,7 +699,6 @@ let start_modtype interp_modast id args mtys fs = openmodtype_info := sub_mty_l; let prefix = Lib.start_modtype id mp fs in Nametab.push_dir (Nametab.Until 1) (fst prefix) (DirOpenModtype prefix); - Lib.add_frozen_state (); if_xml (Hook.get f_xml_start_module_type) mp; mp @@ -719,7 +716,6 @@ let end_modtype () = assert (eq_full_path (fst oname) (fst oldoname)); assert (ModPath.equal (mp_of_kn (snd oname)) mp); - Lib.add_frozen_state ()(* to prevent recaching *); if_xml (Hook.get f_xml_end_module_type) mp; mp @@ -894,8 +890,7 @@ let get_library_native_symbols dir = let start_library dir = let mp = Global.start_library dir in openmod_info := default_module_info; - Lib.start_compilation dir mp; - Lib.add_frozen_state () + Lib.start_compilation dir mp let end_library_hook = ref ignore let append_end_library_hook f = diff --git a/library/global.ml b/library/global.ml index 1ba86699d3..6d80012f47 100644 --- a/library/global.ml +++ b/library/global.ml @@ -176,19 +176,14 @@ let type_of_global_unsafe r = Vars.subst_instance_constr (Univ.UContext.instance univs) ty | IndRef ind -> let (mib, oib as specif) = Inductive.lookup_mind_specif env ind in - let inst = - if mib.Declarations.mind_polymorphic then - Univ.UContext.instance mib.Declarations.mind_universes - else Univ.Instance.empty - in + let inst = Declareops.inductive_polymorphic_instance mib in Inductive.type_of_inductive env (specif, inst) | ConstructRef cstr -> let (mib,oib as specif) = Inductive.lookup_mind_specif env (inductive_of_constructor cstr) in - let inst = Univ.UContext.instance mib.Declarations.mind_universes in - Inductive.type_of_constructor (cstr,inst) specif + let inst = Declareops.inductive_polymorphic_instance mib in + Inductive.type_of_constructor (cstr,inst) specif let type_of_global_in_context env r = - let open Declarations in match r with | VarRef id -> Environ.named_type id env, Univ.UContext.empty | ConstRef c -> @@ -199,21 +194,17 @@ let type_of_global_in_context env r = Typeops.type_of_constant_type env cb.Declarations.const_type, univs | IndRef ind -> let (mib, oib as specif) = Inductive.lookup_mind_specif env ind in - let univs = - if mib.mind_polymorphic then Univ.instantiate_univ_context mib.mind_universes - else Univ.UContext.empty - in Inductive.type_of_inductive env (specif, Univ.UContext.instance univs), univs + let univs = Declareops.inductive_polymorphic_context mib in + Inductive.type_of_inductive env (specif, Univ.UContext.instance univs), univs | ConstructRef cstr -> - let (mib,oib as specif) = Inductive.lookup_mind_specif env (inductive_of_constructor cstr) in - let univs = - if mib.mind_polymorphic then Univ.instantiate_univ_context mib.mind_universes - else Univ.UContext.empty - in - let inst = Univ.UContext.instance univs in - Inductive.type_of_constructor (cstr,inst) specif, univs + let (mib,oib as specif) = + Inductive.lookup_mind_specif env (inductive_of_constructor cstr) + in + let univs = Declareops.inductive_polymorphic_context mib in + let inst = Univ.UContext.instance univs in + Inductive.type_of_constructor (cstr,inst) specif, univs let universes_of_global env r = - let open Declarations in match r with | VarRef id -> Univ.UContext.empty | ConstRef c -> @@ -222,10 +213,11 @@ let universes_of_global env r = (Environ.opaque_tables env) cb | IndRef ind -> let (mib, oib) = Inductive.lookup_mind_specif env ind in - Univ.instantiate_univ_context mib.mind_universes + Declareops.inductive_polymorphic_context mib | ConstructRef cstr -> - let (mib,oib) = Inductive.lookup_mind_specif env (inductive_of_constructor cstr) in - Univ.instantiate_univ_context mib.mind_universes + let (mib,oib) = + Inductive.lookup_mind_specif env (inductive_of_constructor cstr) in + Declareops.inductive_polymorphic_context mib let universes_of_global gr = universes_of_global (env ()) gr diff --git a/library/lib.ml b/library/lib.ml index 9d71a854f0..8127316d73 100644 --- a/library/lib.ml +++ b/library/lib.ml @@ -27,7 +27,6 @@ type node = | ClosedModule of library_segment | OpenedSection of object_prefix * Summary.frozen | ClosedSection of library_segment - | FrozenState of Summary.frozen and library_entry = object_name * node @@ -80,7 +79,6 @@ let classify_segment seg = | (_,OpenedModule (ty,_,_,_)) :: _ -> user_err ~hdr:"Lib.classify_segment" (str "there are still opened " ++ str (module_kind ty) ++ str "s") - | (_,FrozenState _) :: stk -> clean acc stk in clean ([],[],[]) (List.rev seg) @@ -254,10 +252,6 @@ let add_anonymous_leaf ?(cache_first = true) obj = cache_object (oname,obj) end -let add_frozen_state () = - add_anonymous_entry - (FrozenState (Summary.freeze_summaries ~marshallable:`No)) - (* Modules. *) let is_opening_node = function @@ -408,7 +402,7 @@ let find_opening_node id = type variable_info = Context.Named.Declaration.t * Decl_kinds.binding_kind type variable_context = variable_info list -type abstr_info = variable_context * Univ.universe_level_subst * Univ.UContext.t +type abstr_info = variable_context * Univ.universe_level_subst * Univ.AUContext.t type abstr_list = abstr_info Names.Cmap.t * abstr_info Names.Mindmap.t @@ -471,9 +465,9 @@ let add_section_replacement f g poly hyps = let () = check_same_poly poly vars in let sechyps,ctx = extract_hyps (vars,hyps) in let ctx = Univ.ContextSet.to_context ctx in - let subst, ctx = Univ.abstract_universes true ctx in + let subst, ctx = Univ.abstract_universes ctx in let args = instance_from_variable_context (List.rev sechyps) in - sectab := (vars,f (Univ.UContext.instance ctx,args) exps, + sectab := (vars,f (Univ.AUContext.instance ctx,args) exps, g (sechyps,subst,ctx) abs)::sl let add_section_kn poly kn = @@ -544,7 +538,6 @@ let discharge_item ((sp,_ as oname),e) = match e with | Leaf lobj -> Option.map (fun o -> (basename sp,o)) (discharge_object (oname,lobj)) - | FrozenState _ -> None | ClosedSection _ | ClosedModule _ -> None | OpenedSection _ | OpenedModule _ | CompilingLibrary _ -> anomaly (Pp.str "discharge_item.") @@ -585,8 +578,7 @@ let freeze ~marshallable = | n, ClosedModule _ -> Some (n,ClosedModule []) | n, OpenedSection (op, _) -> Some(n,OpenedSection(op,Summary.empty_frozen)) - | n, ClosedSection _ -> Some (n,ClosedSection []) - | _, FrozenState _ -> None) + | n, ClosedSection _ -> Some (n,ClosedSection [])) !lib_state.lib_stk in { !lib_state with lib_stk } | _ -> @@ -596,8 +588,7 @@ let unfreeze st = lib_state := st let init () = unfreeze initial_lib_state; - Summary.init_summaries (); - add_frozen_state () (* Stores e.g. the keywords declared in g_*.ml4 *) + Summary.init_summaries () (* Misc *) diff --git a/library/lib.mli b/library/lib.mli index 9f9d8c7e5f..284d339801 100644 --- a/library/lib.mli +++ b/library/lib.mli @@ -23,7 +23,6 @@ type node = | ClosedModule of library_segment | OpenedSection of Libnames.object_prefix * Summary.frozen | ClosedSection of library_segment - | FrozenState of Summary.frozen and library_segment = (Libnames.object_name * node) list @@ -61,8 +60,6 @@ val pull_to_head : Libnames.object_name -> unit for each of them *) val add_leaves : Names.Id.t -> Libobject.obj list -> Libnames.object_name -val add_frozen_state : unit -> unit - (** {6 ... } *) (** The function [contents] gives access to the current entire segment *) @@ -123,8 +120,6 @@ val end_modtype : Libnames.object_name * Libnames.object_prefix * Summary.frozen * library_segment -(** [Lib.add_frozen_state] must be called after each of the above functions *) - (** {6 Compilation units } *) val start_compilation : Names.DirPath.t -> Names.module_path -> unit @@ -162,7 +157,7 @@ val xml_close_section : (Names.Id.t -> unit) Hook.t (** {6 Section management for discharge } *) type variable_info = Context.Named.Declaration.t * Decl_kinds.binding_kind type variable_context = variable_info list -type abstr_info = variable_context * Univ.universe_level_subst * Univ.UContext.t +type abstr_info = variable_context * Univ.universe_level_subst * Univ.AUContext.t val instance_from_variable_context : variable_context -> Names.Id.t array val named_of_variable_context : variable_context -> Context.Named.t diff --git a/library/library.ml b/library/library.ml index 5a5f99cc51..db05ad2b7b 100644 --- a/library/library.ml +++ b/library/library.ml @@ -575,7 +575,7 @@ let require_library_from_dirpath modrefl export = else add_anonymous_leaf (in_require (needed,modrefl,export)); if !Flags.xml_export then List.iter (Hook.get f_xml_require) modrefl; - add_frozen_state () + () (* the function called by Vernacentries.vernac_import *) diff --git a/library/library.mllib b/library/library.mllib index 6f433b77d1..d94fc22919 100644 --- a/library/library.mllib +++ b/library/library.mllib @@ -1,3 +1,4 @@ +Univops Nameops Libnames Globnames diff --git a/library/univops.ml b/library/univops.ml new file mode 100644 index 0000000000..60c12f0d81 --- /dev/null +++ b/library/univops.ml @@ -0,0 +1,79 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Term +open Univ +open Declarations + +let universes_of_constr c = + let rec aux s c = + match kind_of_term c with + | Const (_, u) | Ind (_, u) | Construct (_, u) -> + LSet.fold LSet.add (Instance.levels u) s + | Sort u when not (Sorts.is_small u) -> + let u = univ_of_sort u in + LSet.fold LSet.add (Universe.levels u) s + | _ -> fold_constr aux s c + in aux LSet.empty c + +let universes_of_inductive mind = + let process auctx = + let u = Univ.AUContext.instance auctx in + let univ_of_one_ind oind = + let arity_univs = + Context.Rel.fold_outside + (fun decl unvs -> + Univ.LSet.union + (Context.Rel.Declaration.fold_constr + (fun cnstr unvs -> + let cnstr = Vars.subst_instance_constr u cnstr in + Univ.LSet.union + (universes_of_constr cnstr) unvs) + decl Univ.LSet.empty) unvs) + oind.mind_arity_ctxt ~init:Univ.LSet.empty + in + Array.fold_left (fun unvs cns -> + let cns = Vars.subst_instance_constr u cns in + Univ.LSet.union (universes_of_constr cns) unvs) arity_univs + oind.mind_nf_lc + in + let univs = + Array.fold_left + (fun unvs pk -> + Univ.LSet.union + (univ_of_one_ind pk) unvs + ) + Univ.LSet.empty mind.mind_packets + in + let mindcnt = Univ.UContext.constraints (Univ.instantiate_univ_context auctx) in + let univs = Univ.LSet.union univs (Univ.universes_of_constraints mindcnt) in + univs + in + match mind.mind_universes with + | Monomorphic_ind _ -> LSet.empty + | Polymorphic_ind auctx -> process auctx + | Cumulative_ind cumi -> process (Univ.ACumulativityInfo.univ_context cumi) + +let restrict_universe_context (univs,csts) s = + (* Universes that are not necessary to typecheck the term. + E.g. univs introduced by tactics and not used in the proof term. *) + let diff = LSet.diff univs s in + let rec aux diff candid univs ness = + let (diff', candid', univs', ness') = + Constraint.fold + (fun (l, d, r as c) (diff, candid, univs, csts) -> + if not (LSet.mem l diff) then + (LSet.remove r diff, candid, univs, Constraint.add c csts) + else if not (LSet.mem r diff) then + (LSet.remove l diff, candid, univs, Constraint.add c csts) + else (diff, Constraint.add c candid, univs, csts)) + candid (diff, Constraint.empty, univs, ness) + in + if ness' == ness then (LSet.diff univs diff', ness) + else aux diff' candid' univs' ness' + in aux diff csts univs Constraint.empty diff --git a/library/univops.mli b/library/univops.mli new file mode 100644 index 0000000000..5b499c75bc --- /dev/null +++ b/library/univops.mli @@ -0,0 +1,17 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Term +open Univ +open Declarations + +(** Shrink a universe context to a restricted set of variables *) + +val universes_of_constr : constr -> universe_set +val universes_of_inductive : mutual_inductive_body -> universe_set +val restrict_universe_context : universe_context_set -> universe_set -> universe_context_set diff --git a/parsing/egramcoq.ml b/parsing/egramcoq.ml index 890ce2deca..35ffa20d08 100644 --- a/parsing/egramcoq.ml +++ b/parsing/egramcoq.ml @@ -227,7 +227,7 @@ type prod_info = production_level * production_position type (_, _) entry = | TTName : ('self, Name.t Loc.located) entry | TTReference : ('self, reference) entry -| TTBigint : ('self, Bigint.bigint) entry +| TTBigint : ('self, Constrexpr.raw_natural_number) entry | TTBinder : ('self, local_binder_expr list) entry | TTConstr : prod_info * 'r target -> ('r, 'r) entry | TTConstrList : prod_info * Tok.t list * 'r target -> ('r, 'r list) entry @@ -337,8 +337,8 @@ match e with | TTBinderListF _ -> { subst with binders = (List.flatten v, false) :: subst.binders } | TTBigint -> begin match forpat with - | ForConstr -> push_constr subst (CAst.make @@ CPrim (Numeral v)) - | ForPattern -> push_constr subst (CAst.make @@ CPatPrim (Numeral v)) + | ForConstr -> push_constr subst (CAst.make @@ CPrim (Numeral (v,true))) + | ForPattern -> push_constr subst (CAst.make @@ CPatPrim (Numeral (v,true))) end | TTReference -> begin match forpat with diff --git a/parsing/g_constr.ml4 b/parsing/g_constr.ml4 index 54bac253d0..de76118026 100644 --- a/parsing/g_constr.ml4 +++ b/parsing/g_constr.ml4 @@ -203,7 +203,7 @@ GEXTEND Gram | c=match_constr -> c | "("; c = operconstr LEVEL "200"; ")" -> (match c.CAst.v with - CPrim (Numeral z) when Bigint.is_pos_or_zero z -> + | CPrim (Numeral (n,true)) -> CAst.make ~loc:(!@loc) @@ CNotation("( _ )",([c],[],[])) | _ -> c) | "{|"; c = record_declaration; "|}" -> c @@ -280,7 +280,7 @@ GEXTEND Gram atomic_constr: [ [ g=global; i=instance -> CAst.make ~loc:!@loc @@ CRef (g,i) | s=sort -> CAst.make ~loc:!@loc @@ CSort s - | n=INT -> CAst.make ~loc:!@loc @@ CPrim (Numeral (Bigint.of_string n)) + | n=INT -> CAst.make ~loc:!@loc @@ CPrim (Numeral (n,true)) | s=string -> CAst.make ~loc:!@loc @@ CPrim (String s) | "_" -> CAst.make ~loc:!@loc @@ CHole (None, IntroAnonymous, None) | "?"; "["; id=ident; "]" -> CAst.make ~loc:!@loc @@ CHole (None, IntroIdentifier id, None) @@ -395,18 +395,18 @@ GEXTEND Gram | "_" -> CAst.make ~loc:!@loc @@ CPatAtom None | "("; p = pattern LEVEL "200"; ")" -> (match p.CAst.v with - | CPatPrim (Numeral z) when Bigint.is_pos_or_zero z -> + | CPatPrim (Numeral (n,true)) -> CAst.make ~loc:!@loc @@ CPatNotation("( _ )",([p],[]),[]) | _ -> p) | "("; p = pattern LEVEL "200"; ":"; ty = lconstr; ")" -> let p = match p with - | { CAst.v = CPatPrim (Numeral z) } when Bigint.is_pos_or_zero z -> + | { CAst.v = CPatPrim (Numeral (n,true)) } -> CAst.make ~loc:!@loc @@ CPatNotation("( _ )",([p],[]),[]) | _ -> p in CAst.make ~loc:!@loc @@ CPatCast (p, ty) - | n = INT -> CAst.make ~loc:!@loc @@ CPatPrim (Numeral (Bigint.of_string n)) + | n = INT -> CAst.make ~loc:!@loc @@ CPatPrim (Numeral (n,true)) | s = string -> CAst.make ~loc:!@loc @@ CPatPrim (String s) ] ] ; impl_ident_tail: diff --git a/parsing/g_prim.ml4 b/parsing/g_prim.ml4 index 78f75a73cb..c77d6e204e 100644 --- a/parsing/g_prim.ml4 +++ b/parsing/g_prim.ml4 @@ -114,7 +114,7 @@ GEXTEND Gram natural: [ [ i = INT -> my_int_of_string (!@loc) i ] ] ; - bigint: (* Negative numbers are dealt with specially *) - [ [ i = INT -> (Bigint.of_string i) ] ] + bigint: (* Negative numbers are dealt with elsewhere *) + [ [ i = INT -> i ] ] ; END diff --git a/parsing/g_proofs.ml4 b/parsing/g_proofs.ml4 index a3f9793bbd..e96a68bc69 100644 --- a/parsing/g_proofs.ml4 +++ b/parsing/g_proofs.ml4 @@ -64,22 +64,14 @@ GEXTEND Gram | IDENT "Show" -> VernacShow (ShowGoal OpenSubgoals) | IDENT "Show"; n = natural -> VernacShow (ShowGoal (NthGoal n)) | IDENT "Show"; id = ident -> VernacShow (ShowGoal (GoalId id)) - | IDENT "Show"; IDENT "Goal" -> VernacShow (ShowGoal (GoalId (Names.Id.of_string "Goal"))) - | IDENT "Show"; IDENT "Goal"; n = string -> - VernacShow (ShowGoal (GoalUid n)) - | IDENT "Show"; IDENT "Implicit"; IDENT "Arguments"; n = OPT natural -> - VernacShow (ShowGoalImplicitly n) - | IDENT "Show"; IDENT "Node" -> VernacShow ShowNode | IDENT "Show"; IDENT "Script" -> VernacShow ShowScript | IDENT "Show"; IDENT "Existentials" -> VernacShow ShowExistentials | IDENT "Show"; IDENT "Universes" -> VernacShow ShowUniverses - | IDENT "Show"; IDENT "Tree" -> VernacShow ShowTree | IDENT "Show"; IDENT "Conjectures" -> VernacShow ShowProofNames | IDENT "Show"; IDENT "Proof" -> VernacShow ShowProof | IDENT "Show"; IDENT "Intro" -> VernacShow (ShowIntros false) | IDENT "Show"; IDENT "Intros" -> VernacShow (ShowIntros true) | IDENT "Show"; IDENT "Match"; id = reference -> VernacShow (ShowMatch id) - | IDENT "Show"; IDENT "Thesis" -> VernacShow ShowThesis | IDENT "Guarded" -> VernacCheckGuard (* Hints for Auto and EAuto *) | IDENT "Create"; IDENT "HintDb" ; diff --git a/parsing/g_vernac.ml4 b/parsing/g_vernac.ml4 index 893605499c..dbd2fc4016 100644 --- a/parsing/g_vernac.ml4 +++ b/parsing/g_vernac.ml4 @@ -51,6 +51,20 @@ let make_bullet s = | '*' -> Star n | _ -> assert false +let extraction_err ~loc = + if not (Mltop.module_is_known "extraction_plugin") then + CErrors.user_err ~loc (str "Please do first a Require Extraction.") + else + (* The right grammar entries should have been loaded. + We could only end here in case of syntax error. *) + raise (Stream.Error "unexpected end of command") + +let funind_err ~loc = + if not (Mltop.module_is_known "recdef_plugin") then + CErrors.user_err ~loc (str "Please do first a Require Import FunInd.") + else + raise (Stream.Error "unexpected end of command") (* Same as above... *) + GEXTEND Gram GLOBAL: vernac gallina_ext noedit_mode subprf; vernac: FIRST @@ -148,11 +162,16 @@ GEXTEND Gram | IDENT "Let"; id = identref; b = def_body -> VernacDefinition ((Some Discharge, Definition), (id, None), b) (* Gallina inductive declarations *) - | priv = private_token; f = finite_token; + | cum = cumulativity_token; priv = private_token; f = finite_token; indl = LIST1 inductive_definition SEP "with" -> let (k,f) = f in - let indl=List.map (fun ((a,b,c,d),e) -> ((a,b,c,k,d),e)) indl in - VernacInductive (priv,f,indl) + let indl=List.map (fun ((a,b,c,d),e) -> ((a,b,c,k,d),e)) indl in + let cum = + match cum with + Some b -> b + | None -> Flags.is_inductive_cumulativity () + in + VernacInductive (cum, priv,f,indl) | "Fixpoint"; recs = LIST1 rec_definition SEP "with" -> VernacFixpoint (None, recs) | IDENT "Let"; "Fixpoint"; recs = LIST1 rec_definition SEP "with" -> @@ -213,13 +232,16 @@ GEXTEND Gram r = universe_level -> (l, ord, r) ] ] ; finite_token: - [ [ "Inductive" -> (Inductive_kw,Finite) - | "CoInductive" -> (CoInductive,CoFinite) - | "Variant" -> (Variant,BiFinite) + [ [ IDENT "Inductive" -> (Inductive_kw,Finite) + | IDENT "CoInductive" -> (CoInductive,CoFinite) + | IDENT "Variant" -> (Variant,BiFinite) | IDENT "Record" -> (Record,BiFinite) | IDENT "Structure" -> (Structure,BiFinite) | IDENT "Class" -> (Class true,BiFinite) ] ] ; + cumulativity_token: + [ [ IDENT "Cumulative" -> Some true | IDENT "NonCumulative" -> Some false | -> None ] ] + ; private_token: [ [ IDENT "Private" -> true | -> false ] ] ; @@ -841,6 +863,22 @@ GEXTEND Gram | IDENT "DelPath"; dir = ne_string -> VernacRemoveLoadPath dir + (* Some plugins are not loaded initially anymore : extraction, + and funind. To ease this transition toward a mandatory Require, + we hack here the vernac grammar in order to get customized + error messages telling what to Require instead of the dreadful + "Illegal begin of vernac". Normally, these fake grammar entries + are overloaded later by the grammar extensions in these plugins. + This code is meant to be removed in a few releases, when this + transition is considered finished. *) + + | IDENT "Extraction" -> extraction_err ~loc:!@loc + | IDENT "Extract" -> extraction_err ~loc:!@loc + | IDENT "Recursive"; IDENT "Extraction" -> extraction_err ~loc:!@loc + | IDENT "Separate"; IDENT "Extraction" -> extraction_err ~loc:!@loc + | IDENT "Function" -> funind_err ~loc:!@loc + | IDENT "Functional" -> funind_err ~loc:!@loc + (* Type-Checking (pas dans le refman) *) | "Type"; c = lconstr -> VernacGlobalCheck c diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index 959e8ddf52..9fb3daabaf 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -199,7 +199,7 @@ module Prim : val pattern_identref : Id.t located Gram.entry val base_ident : Id.t Gram.entry val natural : int Gram.entry - val bigint : Bigint.bigint Gram.entry + val bigint : Constrexpr.raw_natural_number Gram.entry val integer : int Gram.entry val string : string Gram.entry val lstring : string located Gram.entry diff --git a/plugins/cc/cctac.ml b/plugins/cc/cctac.ml index 1ce1660b32..0f5b806644 100644 --- a/plugins/cc/cctac.ml +++ b/plugins/cc/cctac.ml @@ -255,7 +255,7 @@ let app_global_with_holes f args n = Tacticals.New.pf_constr_of_global (Lazy.force f) >>= fun fc -> let env = Proofview.Goal.env gl in let concl = Proofview.Goal.concl gl in - Refine.refine begin fun sigma -> + Refine.refine ~typecheck:false begin fun sigma -> let t = Tacmach.New.pf_get_type_of gl fc in let t = Termops.prod_applist sigma t (Array.to_list args) in let ans = mkApp (fc, args) in diff --git a/plugins/extraction/ExtrHaskellBasic.v b/plugins/extraction/ExtrHaskellBasic.v index 294d61023b..d08a81da64 100644 --- a/plugins/extraction/ExtrHaskellBasic.v +++ b/plugins/extraction/ExtrHaskellBasic.v @@ -1,5 +1,7 @@ (** Extraction to Haskell : use of basic Haskell types *) +Require Coq.extraction.Extraction. + Extract Inductive bool => "Prelude.Bool" [ "Prelude.True" "Prelude.False" ]. Extract Inductive option => "Prelude.Maybe" [ "Prelude.Just" "Prelude.Nothing" ]. Extract Inductive unit => "()" [ "()" ]. diff --git a/plugins/extraction/ExtrHaskellNatInt.v b/plugins/extraction/ExtrHaskellNatInt.v index e94e7d42bd..267322d9ed 100644 --- a/plugins/extraction/ExtrHaskellNatInt.v +++ b/plugins/extraction/ExtrHaskellNatInt.v @@ -1,5 +1,7 @@ (** Extraction of [nat] into Haskell's [Int] *) +Require Coq.extraction.Extraction. + Require Import Arith. Require Import ExtrHaskellNatNum. diff --git a/plugins/extraction/ExtrHaskellNatInteger.v b/plugins/extraction/ExtrHaskellNatInteger.v index 038f0ed817..4c5c71f58a 100644 --- a/plugins/extraction/ExtrHaskellNatInteger.v +++ b/plugins/extraction/ExtrHaskellNatInteger.v @@ -1,5 +1,7 @@ (** Extraction of [nat] into Haskell's [Integer] *) +Require Coq.extraction.Extraction. + Require Import Arith. Require Import ExtrHaskellNatNum. diff --git a/plugins/extraction/ExtrHaskellNatNum.v b/plugins/extraction/ExtrHaskellNatNum.v index 244eb85fc2..fabe9a4c67 100644 --- a/plugins/extraction/ExtrHaskellNatNum.v +++ b/plugins/extraction/ExtrHaskellNatNum.v @@ -6,6 +6,8 @@ * implements [Num]. *) +Require Coq.extraction.Extraction. + Require Import Arith. Require Import EqNat. diff --git a/plugins/extraction/ExtrHaskellString.v b/plugins/extraction/ExtrHaskellString.v index 3558f4f254..ac1f6f9130 100644 --- a/plugins/extraction/ExtrHaskellString.v +++ b/plugins/extraction/ExtrHaskellString.v @@ -2,6 +2,8 @@ * Special handling of ascii and strings for extraction to Haskell. *) +Require Coq.extraction.Extraction. + Require Import Ascii. Require Import String. diff --git a/plugins/extraction/ExtrHaskellZInt.v b/plugins/extraction/ExtrHaskellZInt.v index 66690851a7..0345ffc4e8 100644 --- a/plugins/extraction/ExtrHaskellZInt.v +++ b/plugins/extraction/ExtrHaskellZInt.v @@ -1,5 +1,7 @@ (** Extraction of [Z] into Haskell's [Int] *) +Require Coq.extraction.Extraction. + Require Import ZArith. Require Import ExtrHaskellZNum. diff --git a/plugins/extraction/ExtrHaskellZInteger.v b/plugins/extraction/ExtrHaskellZInteger.v index f192f16ee8..f7f9e2f80d 100644 --- a/plugins/extraction/ExtrHaskellZInteger.v +++ b/plugins/extraction/ExtrHaskellZInteger.v @@ -1,5 +1,7 @@ (** Extraction of [Z] into Haskell's [Integer] *) +Require Coq.extraction.Extraction. + Require Import ZArith. Require Import ExtrHaskellZNum. diff --git a/plugins/extraction/ExtrHaskellZNum.v b/plugins/extraction/ExtrHaskellZNum.v index cbbfda75e5..4141bd203f 100644 --- a/plugins/extraction/ExtrHaskellZNum.v +++ b/plugins/extraction/ExtrHaskellZNum.v @@ -6,6 +6,8 @@ * implements [Num]. *) +Require Coq.extraction.Extraction. + Require Import ZArith. Require Import EqNat. diff --git a/plugins/extraction/ExtrOcamlBasic.v b/plugins/extraction/ExtrOcamlBasic.v index d9b000c2af..dfdc498638 100644 --- a/plugins/extraction/ExtrOcamlBasic.v +++ b/plugins/extraction/ExtrOcamlBasic.v @@ -6,6 +6,8 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +Require Coq.extraction.Extraction. + (** Extraction to Ocaml : use of basic Ocaml types *) Extract Inductive bool => bool [ true false ]. diff --git a/plugins/extraction/ExtrOcamlBigIntConv.v b/plugins/extraction/ExtrOcamlBigIntConv.v index c42938c8ec..78ee460856 100644 --- a/plugins/extraction/ExtrOcamlBigIntConv.v +++ b/plugins/extraction/ExtrOcamlBigIntConv.v @@ -13,6 +13,8 @@ simplifies the use of [Big_int] (it can be found in the sources of Coq). *) +Require Coq.extraction.Extraction. + Require Import Arith ZArith. Parameter bigint : Type. diff --git a/plugins/extraction/ExtrOcamlIntConv.v b/plugins/extraction/ExtrOcamlIntConv.v index 515fa52dfa..fcfea352a7 100644 --- a/plugins/extraction/ExtrOcamlIntConv.v +++ b/plugins/extraction/ExtrOcamlIntConv.v @@ -10,6 +10,8 @@ Nota: no check that [int] values aren't generating overflows *) +Require Coq.extraction.Extraction. + Require Import Arith ZArith. Parameter int : Type. diff --git a/plugins/extraction/ExtrOcamlNatBigInt.v b/plugins/extraction/ExtrOcamlNatBigInt.v index 3149e70298..e0837be621 100644 --- a/plugins/extraction/ExtrOcamlNatBigInt.v +++ b/plugins/extraction/ExtrOcamlNatBigInt.v @@ -8,6 +8,8 @@ (** Extraction of [nat] into Ocaml's [big_int] *) +Require Coq.extraction.Extraction. + Require Import Arith Even Div2 EqNat Euclid. Require Import ExtrOcamlBasic. diff --git a/plugins/extraction/ExtrOcamlNatInt.v b/plugins/extraction/ExtrOcamlNatInt.v index 7c607f7ae6..80da72d43f 100644 --- a/plugins/extraction/ExtrOcamlNatInt.v +++ b/plugins/extraction/ExtrOcamlNatInt.v @@ -8,6 +8,8 @@ (** Extraction of [nat] into Ocaml's [int] *) +Require Coq.extraction.Extraction. + Require Import Arith Even Div2 EqNat Euclid. Require Import ExtrOcamlBasic. diff --git a/plugins/extraction/ExtrOcamlString.v b/plugins/extraction/ExtrOcamlString.v index 6af591eed3..64ca6c85d0 100644 --- a/plugins/extraction/ExtrOcamlString.v +++ b/plugins/extraction/ExtrOcamlString.v @@ -8,6 +8,8 @@ (* Extraction to Ocaml : special handling of ascii and strings *) +Require Coq.extraction.Extraction. + Require Import Ascii String. Extract Inductive ascii => char diff --git a/plugins/extraction/ExtrOcamlZBigInt.v b/plugins/extraction/ExtrOcamlZBigInt.v index c9e8eac0c5..66f188c84e 100644 --- a/plugins/extraction/ExtrOcamlZBigInt.v +++ b/plugins/extraction/ExtrOcamlZBigInt.v @@ -8,6 +8,8 @@ (** Extraction of [positive], [N] and [Z] into Ocaml's [big_int] *) +Require Coq.extraction.Extraction. + Require Import ZArith NArith. Require Import ExtrOcamlBasic. diff --git a/plugins/extraction/ExtrOcamlZInt.v b/plugins/extraction/ExtrOcamlZInt.v index 4d33174b35..c93cfb9d46 100644 --- a/plugins/extraction/ExtrOcamlZInt.v +++ b/plugins/extraction/ExtrOcamlZInt.v @@ -8,6 +8,8 @@ (** Extraction of [positive], [N] and [Z] into Ocaml's [int] *) +Require Coq.extraction.Extraction. + Require Import ZArith NArith. Require Import ExtrOcamlBasic. diff --git a/plugins/extraction/Extraction.v b/plugins/extraction/Extraction.v new file mode 100644 index 0000000000..ab1416b1d6 --- /dev/null +++ b/plugins/extraction/Extraction.v @@ -0,0 +1,9 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +Declare ML Module "extraction_plugin".
\ No newline at end of file diff --git a/plugins/funind/FunInd.v b/plugins/funind/FunInd.v new file mode 100644 index 0000000000..e40aea7764 --- /dev/null +++ b/plugins/funind/FunInd.v @@ -0,0 +1,10 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +Require Coq.extraction.Extraction. +Declare ML Module "recdef_plugin". diff --git a/plugins/funind/Recdef.v b/plugins/funind/Recdef.v index e4433247b4..64f43b8335 100644 --- a/plugins/funind/Recdef.v +++ b/plugins/funind/Recdef.v @@ -6,8 +6,8 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +Require Export Coq.funind.FunInd. Require Import PeanoNat. - Require Compare_dec. Require Wf_nat. diff --git a/plugins/funind/functional_principles_types.ml b/plugins/funind/functional_principles_types.ml index 70245a8b1e..8ffd15f9fb 100644 --- a/plugins/funind/functional_principles_types.ml +++ b/plugins/funind/functional_principles_types.ml @@ -371,12 +371,12 @@ let generate_functional_principle (evd: Evd.evar_map ref) begin begin try - let id = Pfedit.get_current_proof_name () in + let id = Proof_global.get_current_proof_name () in let s = Id.to_string id in let n = String.length "___________princ_________" in if String.length s >= n then if String.equal (String.sub s 0 n) "___________princ_________" - then Pfedit.delete_current_proof () + then Proof_global.discard_current () else () else () with e when CErrors.noncritical e -> () @@ -524,12 +524,12 @@ let make_scheme evd (fas : (pconstant*glob_sort) list) : Safe_typing.private_con begin begin try - let id = Pfedit.get_current_proof_name () in + let id = Proof_global.get_current_proof_name () in let s = Id.to_string id in let n = String.length "___________princ_________" in if String.length s >= n then if String.equal (String.sub s 0 n) "___________princ_________" - then Pfedit.delete_current_proof () + then Proof_global.discard_current () else () else () with e when CErrors.noncritical e -> () diff --git a/plugins/funind/glob_term_to_relation.ml b/plugins/funind/glob_term_to_relation.ml index 0e2ca49000..db2af2be53 100644 --- a/plugins/funind/glob_term_to_relation.ml +++ b/plugins/funind/glob_term_to_relation.ml @@ -1459,7 +1459,9 @@ let do_build_inductive (* in *) let _time2 = System.get_time () in try - with_full_print (Flags.silently (Command.do_mutual_inductive rel_inds (Flags.is_universe_polymorphism ()) false)) Decl_kinds.Finite + with_full_print + (Flags.silently (Command.do_mutual_inductive rel_inds (Flags.is_universe_polymorphism ()) false false)) + Decl_kinds.Finite with | UserError(s,msg) as e -> let _time3 = System.get_time () in @@ -1470,7 +1472,7 @@ let do_build_inductive in let msg = str "while trying to define"++ spc () ++ - Ppvernac.pr_vernac (Vernacexpr.VernacInductive(false,Decl_kinds.Finite,repacked_rel_inds)) + Ppvernac.pr_vernac (Vernacexpr.VernacInductive(false,false,Decl_kinds.Finite,repacked_rel_inds)) ++ fnl () ++ msg in @@ -1485,7 +1487,7 @@ let do_build_inductive in let msg = str "while trying to define"++ spc () ++ - Ppvernac.pr_vernac (Vernacexpr.VernacInductive(false,Decl_kinds.Finite,repacked_rel_inds)) + Ppvernac.pr_vernac (Vernacexpr.VernacInductive(false,false,Decl_kinds.Finite,repacked_rel_inds)) ++ fnl () ++ CErrors.print reraise in diff --git a/plugins/funind/glob_termops.ml b/plugins/funind/glob_termops.ml index a7481370a3..726a8203d7 100644 --- a/plugins/funind/glob_termops.ml +++ b/plugins/funind/glob_termops.ml @@ -722,7 +722,7 @@ let resolve_and_replace_implicits ?(flags=Pretyping.all_and_fail_flags) ?(expect (* we first (pseudo) understand [rt] and get back the computed evar_map *) (* FIXME : JF (30/03/2017) I'm not completely sure to have split understand as needed. If someone knows how to prevent solved existantial removal in understand, please do not hesitate to change the computation of [ctx] here *) - let ctx,_ = Pretyping.ise_pretype_gen flags env sigma Pretyping.empty_lvar expected_type rt in + let ctx,_ = Pretyping.ise_pretype_gen flags env sigma Glob_ops.empty_lvar expected_type rt in let ctx, f = Evarutil.nf_evars_and_universes ctx in (* then we map [rt] to replace the implicit holes by their values *) diff --git a/plugins/funind/indfun_common.ml b/plugins/funind/indfun_common.ml index 7558ac7ac2..6fe6888f3d 100644 --- a/plugins/funind/indfun_common.ml +++ b/plugins/funind/indfun_common.ml @@ -161,7 +161,7 @@ let save with_clean id const (locality,_,kind) hook = let kn = declare_constant id ~local (DefinitionEntry const, k) in (locality, ConstRef kn) in - if with_clean then Pfedit.delete_current_proof (); + if with_clean then Proof_global.discard_current (); CEphemeron.iter_opt hook (fun f -> Lemmas.call_hook fix_exn f l r); definition_message id @@ -173,7 +173,7 @@ let cook_proof _ = let get_proof_clean do_reduce = let result = cook_proof do_reduce in - Pfedit.delete_current_proof (); + Proof_global.discard_current (); result let with_full_print f a = diff --git a/plugins/funind/merge.ml b/plugins/funind/merge.ml index c75f7f868c..ba88563d3b 100644 --- a/plugins/funind/merge.ml +++ b/plugins/funind/merge.ml @@ -880,7 +880,7 @@ let merge_inductive (ind1: inductive) (ind2: inductive) (* Declare inductive *) let indl,_,_ = Command.extract_mutual_inductive_declaration_components [(indexpr,[])] in let mie,pl,impls = Command.interp_mutual_inductive indl [] - false (*FIXMEnon-poly *) false (* means not private *) Decl_kinds.Finite (* means: not coinductive *) in + false (* non-cumulative *) false (*FIXMEnon-poly *) false (* means not private *) Decl_kinds.Finite (* means: not coinductive *) in (* Declare the mutual inductive block with its associated schemes *) ignore (Command.declare_mutual_inductive_with_eliminations mie pl impls) diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index 20abde82f2..3cd20a9507 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -1295,7 +1295,7 @@ let is_opaque_constant c = let open_new_goal build_proof sigma using_lemmas ref_ goal_name (gls_type,decompose_and_tac,nb_goal) = (* Pp.msgnl (str "gls_type := " ++ Printer.pr_lconstr gls_type); *) - let current_proof_name = get_current_proof_name () in + let current_proof_name = Proof_global.get_current_proof_name () in let name = match goal_name with | Some s -> s | None -> diff --git a/plugins/ltac/evar_tactics.ml b/plugins/ltac/evar_tactics.ml index a299e11f8a..7ecfa57f6d 100644 --- a/plugins/ltac/evar_tactics.ml +++ b/plugins/ltac/evar_tactics.ml @@ -28,7 +28,7 @@ let instantiate_evar evk (ist,rawc) sigma = let filtered = Evd.evar_filtered_env evi in let constrvars = Tacinterp.extract_ltac_constr_values ist filtered in let lvar = { - Pretyping.ltac_constrs = constrvars; + Glob_term.ltac_constrs = constrvars; ltac_uconstrs = Names.Id.Map.empty; ltac_idents = Names.Id.Map.empty; ltac_genargs = ist.Geninterp.lfun; diff --git a/plugins/ltac/extratactics.ml4 b/plugins/ltac/extratactics.ml4 index 18d7b818cd..7259faecd0 100644 --- a/plugins/ltac/extratactics.ml4 +++ b/plugins/ltac/extratactics.ml4 @@ -365,7 +365,7 @@ let refine_tac ist simple with_classes c = let update = begin fun sigma -> c env sigma end in - let refine = Refine.refine ~unsafe:true update in + let refine = Refine.refine ~typecheck:false update in if simple then refine else refine <*> Tactics.New.reduce_after_refine <*> diff --git a/plugins/ltac/g_tactic.ml4 b/plugins/ltac/g_tactic.ml4 index a971fc79f6..804f734504 100644 --- a/plugins/ltac/g_tactic.ml4 +++ b/plugins/ltac/g_tactic.ml4 @@ -139,14 +139,16 @@ let destruction_arg_of_constr (c,lbind as clbind) = match lbind with end | _ -> ElimOnConstr clbind +let mkNumeral n = Numeral (string_of_int (abs n), 0<=n) + let mkTacCase with_evar = function | [(clear,ElimOnConstr cl),(None,None),None],None -> TacCase (with_evar,(clear,cl)) (* Reinterpret numbers as a notation for terms *) | [(clear,ElimOnAnonHyp n),(None,None),None],None -> TacCase (with_evar, - (clear,(CAst.make @@ CPrim (Numeral (Bigint.of_int n)), - NoBindings))) + (clear,(CAst.make @@ CPrim (mkNumeral n), + NoBindings))) (* Reinterpret ident as notations for variables in the context *) (* because we don't know if they are quantified or not *) | [(clear,ElimOnIdent id),(None,None),None],None -> diff --git a/plugins/ltac/rewrite.ml b/plugins/ltac/rewrite.ml index 3927ca7ce1..fad181c897 100644 --- a/plugins/ltac/rewrite.ml +++ b/plugins/ltac/rewrite.ml @@ -1539,7 +1539,7 @@ let assert_replacing id newt tac = | d :: rem -> insert_dependent env sigma (LocalAssum (NamedDecl.get_id d, newt)) [] after @ rem in let env' = Environ.reset_with_named_context (val_of_named_context nc) env in - Refine.refine ~unsafe:false begin fun sigma -> + Refine.refine ~typecheck:true begin fun sigma -> let (sigma, ev) = Evarutil.new_evar env' sigma concl in let (sigma, ev') = Evarutil.new_evar env sigma newt in let map d = @@ -1573,7 +1573,7 @@ let cl_rewrite_clause_newtac ?abs ?origsigma ~progress strat clause = match clause, prf with | Some id, Some p -> let tac = tclTHENLIST [ - Refine.refine ~unsafe:false (fun h -> (h,p)); + Refine.refine ~typecheck:true (fun h -> (h,p)); Proofview.Unsafe.tclNEWGOALS gls; ] in Proofview.Unsafe.tclEVARS undef <*> @@ -1590,7 +1590,7 @@ let cl_rewrite_clause_newtac ?abs ?origsigma ~progress strat clause = let (sigma, ev) = Evarutil.new_evar env sigma newt in (sigma, mkApp (p, [| ev |])) end in - Refine.refine ~unsafe:false make <*> Proofview.Unsafe.tclNEWGOALS gls + Refine.refine ~typecheck:true make <*> Proofview.Unsafe.tclNEWGOALS gls end | None, None -> Proofview.Unsafe.tclEVARS undef <*> diff --git a/plugins/ltac/tacexpr.mli b/plugins/ltac/tacexpr.mli index 9b6ac8a9ae..67893bd11e 100644 --- a/plugins/ltac/tacexpr.mli +++ b/plugins/ltac/tacexpr.mli @@ -386,7 +386,7 @@ type ltac_call_kind = | LtacNameCall of ltac_constant | LtacAtomCall of glob_atomic_tactic_expr | LtacVarCall of Id.t * glob_tactic_expr - | LtacConstrInterp of Glob_term.glob_constr * Pretyping.ltac_var_map + | LtacConstrInterp of Glob_term.glob_constr * Glob_term.ltac_var_map type ltac_trace = ltac_call_kind Loc.located list diff --git a/plugins/ltac/tacinterp.ml b/plugins/ltac/tacinterp.ml index 9d8094205b..0cd3ee2f9c 100644 --- a/plugins/ltac/tacinterp.ml +++ b/plugins/ltac/tacinterp.ml @@ -22,7 +22,6 @@ open Nameops open Libnames open Globnames open Nametab -open Pfedit open Refiner open Tacmach.New open Tactic_debug @@ -605,10 +604,10 @@ let interp_gen kind ist pattern_mode flags env sigma c = let { closure = constrvars ; term } = interp_glob_closure ist env sigma ~kind:kind_for_intern ~pattern_mode c in let vars = { - Pretyping.ltac_constrs = constrvars.typed; - Pretyping.ltac_uconstrs = constrvars.untyped; - Pretyping.ltac_idents = constrvars.idents; - Pretyping.ltac_genargs = ist.lfun; + Glob_term.ltac_constrs = constrvars.typed; + Glob_term.ltac_uconstrs = constrvars.untyped; + Glob_term.ltac_idents = constrvars.idents; + Glob_term.ltac_genargs = ist.lfun; } in (* Jason Gross: To avoid unnecessary modifications to tacinterp, as suggested by Arnaud Spiwack, we run push_trace immediately. We do @@ -629,7 +628,7 @@ let interp_gen kind ist pattern_mode flags env sigma c = let constr_flags () = { use_typeclasses = true; solve_unification_constraints = true; - use_hook = solve_by_implicit_tactic (); + use_hook = Pfedit.solve_by_implicit_tactic (); fail_evar = true; expand_evars = true } @@ -644,14 +643,14 @@ let interp_type = interp_constr_gen IsType let open_constr_use_classes_flags () = { use_typeclasses = true; solve_unification_constraints = true; - use_hook = solve_by_implicit_tactic (); + use_hook = Pfedit.solve_by_implicit_tactic (); fail_evar = false; expand_evars = true } let open_constr_no_classes_flags () = { use_typeclasses = false; solve_unification_constraints = true; - use_hook = solve_by_implicit_tactic (); + use_hook = Pfedit.solve_by_implicit_tactic (); fail_evar = false; expand_evars = true } diff --git a/plugins/ltac/tactic_debug.ml b/plugins/ltac/tactic_debug.ml index b909c930db..53dc800231 100644 --- a/plugins/ltac/tactic_debug.ml +++ b/plugins/ltac/tactic_debug.ml @@ -364,7 +364,7 @@ let explain_ltac_call_trace last trace loc = | Tacexpr.LtacAtomCall te -> quote (Pptactic.pr_glob_tactic (Global.env()) (Tacexpr.TacAtom (Loc.tag te))) - | Tacexpr.LtacConstrInterp (c, { Pretyping.ltac_constrs = vars }) -> + | Tacexpr.LtacConstrInterp (c, { Glob_term.ltac_constrs = vars }) -> quote (Printer.pr_glob_constr_env (Global.env()) c) ++ (if not (Id.Map.is_empty vars) then strbrk " (with " ++ diff --git a/plugins/ltac/tauto.ml b/plugins/ltac/tauto.ml index 5eacb1a95e..2a8ed72387 100644 --- a/plugins/ltac/tauto.ml +++ b/plugins/ltac/tauto.ml @@ -66,7 +66,7 @@ let negation_unfolding = ref true (* Whether inner iff are unfolded *) let iff_unfolding = ref false -let unfold_iff () = !iff_unfolding || Flags.version_less_or_equal Flags.V8_2 +let unfold_iff () = !iff_unfolding open Goptions let _ = @@ -79,7 +79,7 @@ let _ = let _ = declare_bool_option - { optdepr = false; + { optdepr = true; (* remove in 8.8 *) optname = "unfolding of iff in intuition"; optkey = ["Intuition";"Iff";"Unfolding"]; optread = (fun () -> !iff_unfolding); diff --git a/plugins/micromega/MExtraction.v b/plugins/micromega/MExtraction.v index 2451aeada7..95f135c8f0 100644 --- a/plugins/micromega/MExtraction.v +++ b/plugins/micromega/MExtraction.v @@ -14,6 +14,7 @@ (* Used to generate micromega.ml *) +Require Extraction. Require Import ZMicromega. Require Import QMicromega. Require Import RMicromega. @@ -48,7 +49,10 @@ Extract Constant Rmult => "( * )". Extract Constant Ropp => "fun x -> - x". Extract Constant Rinv => "fun x -> 1 / x". -Extraction "plugins/micromega/generated_micromega.ml" +(** We now extract to stdout, see comment in Makefile.build *) + +(*Extraction "plugins/micromega/micromega.ml" *) +Recursive Extraction List.map simpl_cone (*map_cone indexes*) denorm Qpower vm_add n_of_Z N.of_nat ZTautoChecker ZWeakChecker QTautoChecker RTautoChecker find. diff --git a/plugins/omega/PreOmega.v b/plugins/omega/PreOmega.v index 6c0e2d776d..2780be4aaa 100644 --- a/plugins/omega/PreOmega.v +++ b/plugins/omega/PreOmega.v @@ -48,10 +48,13 @@ Ltac zify_unop_var_or_term t thm a := (remember a as za; zify_unop_core t thm za). Ltac zify_unop t thm a := - (* if a is a scalar, we can simply reduce the unop *) + (* If a is a scalar, we can simply reduce the unop. *) + (* Note that simpl wasn't enough to reduce [Z.max 0 0] (#5439) *) let isz := isZcst a in match isz with - | true => simpl (t a) in * + | true => + let u := eval compute in (t a) in + change (t a) with u in * | _ => zify_unop_var_or_term t thm a end. @@ -165,14 +168,16 @@ Ltac zify_nat_op := rewrite (Nat2Z.inj_mul a b) in * (* O -> Z0 *) - | H : context [ Z.of_nat O ] |- _ => simpl (Z.of_nat O) in H - | |- context [ Z.of_nat O ] => simpl (Z.of_nat O) + | H : context [ Z.of_nat O ] |- _ => change (Z.of_nat O) with Z0 in H + | |- context [ Z.of_nat O ] => change (Z.of_nat O) with Z0 (* S -> number or Z.succ *) | H : context [ Z.of_nat (S ?a) ] |- _ => let isnat := isnatcst a in match isnat with - | true => simpl (Z.of_nat (S a)) in H + | true => + let t := eval compute in (Z.of_nat (S a)) in + change (Z.of_nat (S a)) with t in H | _ => rewrite (Nat2Z.inj_succ a) in H | _ => (* if the [rewrite] fails (most likely a dependent occurence of [Z.of_nat (S a)]), hide [Z.of_nat (S a)] in this one hypothesis *) @@ -181,7 +186,9 @@ Ltac zify_nat_op := | |- context [ Z.of_nat (S ?a) ] => let isnat := isnatcst a in match isnat with - | true => simpl (Z.of_nat (S a)) + | true => + let t := eval compute in (Z.of_nat (S a)) in + change (Z.of_nat (S a)) with t | _ => rewrite (Nat2Z.inj_succ a) | _ => (* if the [rewrite] fails (most likely a dependent occurence of [Z.of_nat (S a)]), hide [Z.of_nat (S a)] in the goal *) @@ -264,8 +271,8 @@ Ltac zify_positive_op := | |- context [ Zpos (Pos.max ?a ?b) ] => rewrite (Pos2Z.inj_max a b) (* Pos.sub -> Z.max 1 (Z.sub ... ...) *) - | H : context [ Zpos (Pos.sub ?a ?b) ] |- _ => rewrite (Pos2Z.inj_sub a b) in H - | |- context [ Zpos (Pos.sub ?a ?b) ] => rewrite (Pos2Z.inj_sub a b) + | H : context [ Zpos (Pos.sub ?a ?b) ] |- _ => rewrite (Pos2Z.inj_sub_max a b) in H + | |- context [ Zpos (Pos.sub ?a ?b) ] => rewrite (Pos2Z.inj_sub_max a b) (* Pos.succ -> Z.succ *) | H : context [ Zpos (Pos.succ ?a) ] |- _ => rewrite (Pos2Z.inj_succ a) in H diff --git a/plugins/omega/coq_omega.ml b/plugins/omega/coq_omega.ml index 9cb94b68df..440a10bfb9 100644 --- a/plugins/omega/coq_omega.ml +++ b/plugins/omega/coq_omega.ml @@ -652,7 +652,7 @@ let clever_rewrite_base_poly typ p result theorem = let full = pf_concl gl in let env = pf_env gl in let (abstracted,occ) = abstract_path (project gl) typ (List.rev p) full in - Refine.refine begin fun sigma -> + Refine.refine ~typecheck:false begin fun sigma -> let t = applist (mkLambda @@ -688,7 +688,7 @@ let clever_rewrite_gen_nat p result (t,args) = (** Solve using the term the term [t _] *) let refine_app gl t = let open Tacmach.New in - Refine.refine begin fun sigma -> + Refine.refine ~typecheck:false begin fun sigma -> let env = pf_env gl in let ht = match EConstr.kind sigma (pf_get_type_of gl t) with | Prod (_, t, _) -> t diff --git a/plugins/setoid_ring/newring.ml b/plugins/setoid_ring/newring.ml index ee75d2908e..da21f64ab1 100644 --- a/plugins/setoid_ring/newring.ml +++ b/plugins/setoid_ring/newring.ml @@ -153,8 +153,8 @@ let ic_unsafe c = (*FIXME remove *) let decl_constant na ctx c = let open Term in - let vars = Universes.universes_of_constr c in - let ctx = Universes.restrict_universe_context (Univ.ContextSet.of_context ctx) vars in + let vars = Univops.universes_of_constr c in + let ctx = Univops.restrict_universe_context (Univ.ContextSet.of_context ctx) vars in mkConst(declare_constant (Id.of_string na) (DefinitionEntry (definition_entry ~opaque:true ~univs:(Univ.ContextSet.to_context ctx) c), diff --git a/plugins/ssr/ssrcommon.ml b/plugins/ssr/ssrcommon.ml index d389f70859..490ded9d4d 100644 --- a/plugins/ssr/ssrcommon.ml +++ b/plugins/ssr/ssrcommon.ml @@ -226,8 +226,8 @@ let isAppInd gl c = let interp_refine ist gl rc = let constrvars = Tacinterp.extract_ltac_constr_values ist (pf_env gl) in - let vars = { Pretyping.empty_lvar with - Pretyping.ltac_constrs = constrvars; ltac_genargs = ist.Tacinterp.lfun + let vars = { Glob_ops.empty_lvar with + Glob_term.ltac_constrs = constrvars; ltac_genargs = ist.Tacinterp.lfun } in let kind = Pretyping.OfType (pf_concl gl) in let flags = { diff --git a/plugins/ssr/ssripats.ml b/plugins/ssr/ssripats.ml index 4a9dddd2ba..7ae9e38248 100644 --- a/plugins/ssr/ssripats.ml +++ b/plugins/ssr/ssripats.ml @@ -95,7 +95,7 @@ let ssrmkabs id gl = end in Proofview.V82.of_tactic (Proofview.tclTHEN - (Tactics.New.refine step) + (Tactics.New.refine ~typecheck:false step) (Proofview.tclFOCUS 1 3 Proofview.shelve)) gl let ssrmkabstac ids = diff --git a/plugins/ssr/ssrparser.ml4 b/plugins/ssr/ssrparser.ml4 index 3ea8c24314..09917339a7 100644 --- a/plugins/ssr/ssrparser.ml4 +++ b/plugins/ssr/ssrparser.ml4 @@ -346,7 +346,8 @@ let interp_index ist gl idx = | Some c -> let rc = Detyping.detype false [] (pf_env gl) (project gl) c in begin match Notation.uninterp_prim_token rc with - | _, Constrexpr.Numeral bigi -> int_of_string (Bigint.to_string bigi) + | _, Constrexpr.Numeral (s,b) -> + let n = int_of_string s in if b then n else -n | _ -> raise Not_found end | None -> raise Not_found diff --git a/plugins/syntax/int31_syntax.ml b/plugins/syntax/int31_syntax.ml new file mode 100644 index 0000000000..5d1412ba76 --- /dev/null +++ b/plugins/syntax/int31_syntax.ml @@ -0,0 +1,100 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open API + +(* Poor's man DECLARE PLUGIN *) +let __coq_plugin_name = "int31_syntax_plugin" +let () = Mltop.add_known_module __coq_plugin_name + +(* digit-based syntax for int31 *) + +open Bigint +open Names +open Globnames +open Glob_term + +(*** Constants for locating int31 constructors ***) + +let make_dir l = DirPath.make (List.rev_map Id.of_string l) +let make_path dir id = Libnames.make_path (make_dir dir) (Id.of_string id) + +let make_mind mp id = Names.MutInd.make2 mp (Label.make id) +let make_mind_mpfile dir id = make_mind (ModPath.MPfile (make_dir dir)) id +let make_mind_mpdot dir modname id = + let mp = ModPath.MPdot (ModPath.MPfile (make_dir dir), Label.make modname) + in make_mind mp id + + +(* int31 stuff *) +let int31_module = ["Coq"; "Numbers"; "Cyclic"; "Int31"; "Int31"] +let int31_path = make_path int31_module "int31" +let int31_id = make_mind_mpfile int31_module +let int31_scope = "int31_scope" + +let int31_construct = ConstructRef ((int31_id "int31",0),1) + +let int31_0 = ConstructRef ((int31_id "digits",0),1) +let int31_1 = ConstructRef ((int31_id "digits",0),2) + +(*** Definition of the Non_closed exception, used in the pretty printing ***) +exception Non_closed + +(*** Parsing for int31 in digital notation ***) + +(* parses a *non-negative* integer (from bigint.ml) into an int31 + wraps modulo 2^31 *) +let int31_of_pos_bigint ?loc n = + let ref_construct = CAst.make ?loc (GRef (int31_construct, None)) in + let ref_0 = CAst.make ?loc (GRef (int31_0, None)) in + let ref_1 = CAst.make ?loc (GRef (int31_1, None)) in + let rec args counter n = + if counter <= 0 then + [] + else + let (q,r) = div2_with_rest n in + (if r then ref_1 else ref_0)::(args (counter-1) q) + in + CAst.make ?loc (GApp (ref_construct, List.rev (args 31 n))) + +let error_negative ?loc = + CErrors.user_err ?loc ~hdr:"interp_int31" (Pp.str "int31 are only non-negative numbers.") + +let interp_int31 ?loc n = + if is_pos_or_zero n then + int31_of_pos_bigint ?loc n + else + error_negative ?loc + +(* Pretty prints an int31 *) + +let bigint_of_int31 = + let rec args_parsing args cur = + match args with + | [] -> cur + | { CAst.v = GRef (b,_) }::l when eq_gr b int31_0 -> args_parsing l (mult_2 cur) + | { CAst.v = GRef (b,_) }::l when eq_gr b int31_1 -> args_parsing l (add_1 (mult_2 cur)) + | _ -> raise Non_closed + in + function + | { CAst.v = GApp ({ CAst.v = GRef (c, _) }, args) } when eq_gr c int31_construct -> args_parsing args zero + | _ -> raise Non_closed + +let uninterp_int31 i = + try + Some (bigint_of_int31 i) + with Non_closed -> + None + +(* Actually declares the interpreter for int31 *) +let _ = Notation.declare_numeral_interpreter int31_scope + (int31_path, int31_module) + interp_int31 + ([CAst.make (GRef (int31_construct, None))], + uninterp_int31, + true) diff --git a/plugins/syntax/int31_syntax_plugin.mlpack b/plugins/syntax/int31_syntax_plugin.mlpack new file mode 100644 index 0000000000..54a5bc0cd1 --- /dev/null +++ b/plugins/syntax/int31_syntax_plugin.mlpack @@ -0,0 +1 @@ +Int31_syntax diff --git a/plugins/syntax/numbers_syntax.ml b/plugins/syntax/numbers_syntax.ml deleted file mode 100644 index fb657c47ce..0000000000 --- a/plugins/syntax/numbers_syntax.ml +++ /dev/null @@ -1,313 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -open API - -(* Poor's man DECLARE PLUGIN *) -let __coq_plugin_name = "numbers_syntax_plugin" -let () = Mltop.add_known_module __coq_plugin_name - -(* digit-based syntax for int31, bigN bigZ and bigQ *) - -open Bigint -open Names -open Globnames -open Glob_term - -(*** Constants for locating int31 / bigN / bigZ / bigQ constructors ***) - -let make_dir l = DirPath.make (List.rev_map Id.of_string l) -let make_path dir id = Libnames.make_path (make_dir dir) (Id.of_string id) - -let make_mind mp id = Names.MutInd.make2 mp (Label.make id) -let make_mind_mpfile dir id = make_mind (ModPath.MPfile (make_dir dir)) id -let make_mind_mpdot dir modname id = - let mp = ModPath.MPdot (ModPath.MPfile (make_dir dir), Label.make modname) - in make_mind mp id - - -(* int31 stuff *) -let int31_module = ["Coq"; "Numbers"; "Cyclic"; "Int31"; "Int31"] -let int31_path = make_path int31_module "int31" -let int31_id = make_mind_mpfile int31_module -let int31_scope = "int31_scope" - -let int31_construct = ConstructRef ((int31_id "int31",0),1) - -let int31_0 = ConstructRef ((int31_id "digits",0),1) -let int31_1 = ConstructRef ((int31_id "digits",0),2) - - -(* bigN stuff*) -let zn2z_module = ["Coq"; "Numbers"; "Cyclic"; "DoubleCyclic"; "DoubleType"] -let zn2z_path = make_path zn2z_module "zn2z" -let zn2z_id = make_mind_mpfile zn2z_module - -let zn2z_W0 = ConstructRef ((zn2z_id "zn2z",0),1) -let zn2z_WW = ConstructRef ((zn2z_id "zn2z",0),2) - -let bigN_module = ["Coq"; "Numbers"; "Natural"; "BigN"; "BigN" ] -let bigN_path = make_path (bigN_module@["BigN"]) "t" -let bigN_t = make_mind_mpdot bigN_module "BigN" "t'" -let bigN_scope = "bigN_scope" - -(* number of inlined level of bigN (actually the level 0 to n_inlined-1 are inlined) *) -let n_inlined = 7 - -let bigN_constructor i = - ConstructRef ((bigN_t,0),(min i n_inlined)+1) - -(*bigZ stuff*) -let bigZ_module = ["Coq"; "Numbers"; "Integer"; "BigZ"; "BigZ" ] -let bigZ_path = make_path (bigZ_module@["BigZ"]) "t" -let bigZ_t = make_mind_mpdot bigZ_module "BigZ" "t_" -let bigZ_scope = "bigZ_scope" - -let bigZ_pos = ConstructRef ((bigZ_t,0),1) -let bigZ_neg = ConstructRef ((bigZ_t,0),2) - - -(*bigQ stuff*) -let bigQ_module = ["Coq"; "Numbers"; "Rational"; "BigQ"; "BigQ"] -let bigQ_path = make_path (bigQ_module@["BigQ"]) "t" -let bigQ_t = make_mind_mpdot bigQ_module "BigQ" "t_" -let bigQ_scope = "bigQ_scope" - -let bigQ_z = ConstructRef ((bigQ_t,0),1) - - -(*** Definition of the Non_closed exception, used in the pretty printing ***) -exception Non_closed - -(*** Parsing for int31 in digital notation ***) - -(* parses a *non-negative* integer (from bigint.ml) into an int31 - wraps modulo 2^31 *) -let int31_of_pos_bigint ?loc n = - let ref_construct = CAst.make ?loc @@ GRef (int31_construct, None) in - let ref_0 = CAst.make ?loc @@ GRef (int31_0, None) in - let ref_1 = CAst.make ?loc @@ GRef (int31_1, None) in - let rec args counter n = - if counter <= 0 then - [] - else - let (q,r) = div2_with_rest n in - (if r then ref_1 else ref_0)::(args (counter-1) q) - in - CAst.make ?loc @@ GApp (ref_construct, List.rev (args 31 n)) - -let error_negative ?loc = - CErrors.user_err ?loc ~hdr:"interp_int31" (Pp.str "int31 are only non-negative numbers.") - -let interp_int31 ?loc n = - if is_pos_or_zero n then - int31_of_pos_bigint ?loc n - else - error_negative ?loc - -(* Pretty prints an int31 *) - -let bigint_of_int31 = - let rec args_parsing args cur = - match args with - | [] -> cur - | { CAst.v = GRef (b,_) }::l when eq_gr b int31_0 -> args_parsing l (mult_2 cur) - | { CAst.v = GRef (b,_) }::l when eq_gr b int31_1 -> args_parsing l (add_1 (mult_2 cur)) - | _ -> raise Non_closed - in - function - | { CAst.v = GApp ({ CAst.v = GRef (c, _)}, args) } when eq_gr c int31_construct -> args_parsing args zero - | _ -> raise Non_closed - -let uninterp_int31 i = - try - Some (bigint_of_int31 i) - with Non_closed -> - None - -(* Actually declares the interpreter for int31 *) -let _ = Notation.declare_numeral_interpreter int31_scope - (int31_path, int31_module) - interp_int31 - ([CAst.make @@ GRef (int31_construct, None)], - uninterp_int31, - true) - - -(*** Parsing for bigN in digital notation ***) -(* the base for bigN (in Coq) that is 2^31 in our case *) -let base = pow two 31 - -(* base of the bigN of height N : (2^31)^(2^n) *) -let rank n = - let rec rk n pow2 = - if n <= 0 then pow2 - else rk (n-1) (mult pow2 pow2) - in rk n base - -(* splits a number bi at height n, that is the rest needs 2^n int31 to be stored - it is expected to be used only when the quotient would also need 2^n int31 to be - stored *) -let split_at n bi = - euclid bi (rank (n-1)) - -(* search the height of the Coq bigint needed to represent the integer bi *) -let height bi = - let rec hght n pow2 = - if less_than bi pow2 then n - else hght (n+1) (mult pow2 pow2) - in hght 0 base - -(* n must be a non-negative integer (from bigint.ml) *) -let word_of_pos_bigint ?loc hght n = - let ref_W0 = CAst.make ?loc @@ GRef (zn2z_W0, None) in - let ref_WW = CAst.make ?loc @@ GRef (zn2z_WW, None) in - let rec decomp hgt n = - if hgt <= 0 then - int31_of_pos_bigint ?loc n - else if equal n zero then - CAst.make ?loc @@ GApp (ref_W0, [CAst.make ?loc @@ GHole (Evar_kinds.InternalHole, Misctypes.IntroAnonymous, None)]) - else - let (h,l) = split_at hgt n in - CAst.make ?loc @@ GApp (ref_WW, [CAst.make ?loc @@ GHole (Evar_kinds.InternalHole, Misctypes.IntroAnonymous, None); - decomp (hgt-1) h; - decomp (hgt-1) l]) - in - decomp hght n - -let bigN_of_pos_bigint ?loc n = - let h = height n in - let ref_constructor = CAst.make ?loc @@ GRef (bigN_constructor h, None) in - let word = word_of_pos_bigint ?loc h n in - let args = - if h < n_inlined then [word] - else [Nat_syntax_plugin.Nat_syntax.nat_of_int ?loc (of_int (h-n_inlined));word] - in - CAst.make ?loc @@ GApp (ref_constructor, args) - -let bigN_error_negative ?loc = - CErrors.user_err ?loc ~hdr:"interp_bigN" (Pp.str "bigN are only non-negative numbers.") - -let interp_bigN ?loc n = - if is_pos_or_zero n then - bigN_of_pos_bigint ?loc n - else - bigN_error_negative ?loc - - -(* Pretty prints a bigN *) - -let bigint_of_word = - let rec get_height rc = - match rc with - | { CAst.v = GApp ({ CAst.v = GRef(c,_)}, [_;lft;rght]) } when eq_gr c zn2z_WW -> - 1+max (get_height lft) (get_height rght) - | _ -> 0 - in - let rec transform hght rc = - match rc with - | { CAst.v = GApp ({ CAst.v = GRef(c,_)},_)} when eq_gr c zn2z_W0-> zero - | { CAst.v = GApp ({ CAst.v = GRef(c,_)}, [_;lft;rght]) } when eq_gr c zn2z_WW-> - let new_hght = hght-1 in - add (mult (rank new_hght) - (transform new_hght lft)) - (transform new_hght rght) - | _ -> bigint_of_int31 rc - in - fun rc -> - let hght = get_height rc in - transform hght rc - -let bigint_of_bigN rc = - match rc with - | { CAst.v = GApp (_,[one_arg]) } -> bigint_of_word one_arg - | { CAst.v = GApp (_,[_;second_arg]) } -> bigint_of_word second_arg - | _ -> raise Non_closed - -let uninterp_bigN rc = - try - Some (bigint_of_bigN rc) - with Non_closed -> - None - - -(* declare the list of constructors of bigN used in the declaration of the - numeral interpreter *) - -let bigN_list_of_constructors = - let rec build i = - if i < n_inlined+1 then - (CAst.make @@ GRef (bigN_constructor i,None))::(build (i+1)) - else - [] - in - build 0 - -(* Actually declares the interpreter for bigN *) -let _ = Notation.declare_numeral_interpreter bigN_scope - (bigN_path, bigN_module) - interp_bigN - (bigN_list_of_constructors, - uninterp_bigN, - true) - - -(*** Parsing for bigZ in digital notation ***) -let interp_bigZ ?loc n = - let ref_pos = CAst.make ?loc @@ GRef (bigZ_pos, None) in - let ref_neg = CAst.make ?loc @@ GRef (bigZ_neg, None) in - if is_pos_or_zero n then - CAst.make ?loc @@ GApp (ref_pos, [bigN_of_pos_bigint ?loc n]) - else - CAst.make ?loc @@ GApp (ref_neg, [bigN_of_pos_bigint ?loc (neg n)]) - -(* pretty printing functions for bigZ *) -let bigint_of_bigZ = function - | { CAst.v = GApp ({ CAst.v = GRef(c,_) }, [one_arg])} when eq_gr c bigZ_pos -> bigint_of_bigN one_arg - | { CAst.v = GApp ({ CAst.v = GRef(c,_) }, [one_arg])} when eq_gr c bigZ_neg -> - let opp_val = bigint_of_bigN one_arg in - if equal opp_val zero then - raise Non_closed - else - neg opp_val - | _ -> raise Non_closed - - -let uninterp_bigZ rc = - try - Some (bigint_of_bigZ rc) - with Non_closed -> - None - -(* Actually declares the interpreter for bigZ *) -let _ = Notation.declare_numeral_interpreter bigZ_scope - (bigZ_path, bigZ_module) - interp_bigZ - ([CAst.make @@ GRef (bigZ_pos, None); - CAst.make @@ GRef (bigZ_neg, None)], - uninterp_bigZ, - true) - -(*** Parsing for bigQ in digital notation ***) -let interp_bigQ ?loc n = - let ref_z = CAst.make ?loc @@ GRef (bigQ_z, None) in - CAst.make ?loc @@ GApp (ref_z, [interp_bigZ ?loc n]) - -let uninterp_bigQ rc = - try match rc with - | { CAst.v = GApp ({ CAst.v = GRef(c,_)}, [one_arg]) } when eq_gr c bigQ_z -> - Some (bigint_of_bigZ one_arg) - | _ -> None (* we don't pretty-print yet fractions *) - with Non_closed -> None - -(* Actually declares the interpreter for bigQ *) -let _ = Notation.declare_numeral_interpreter bigQ_scope - (bigQ_path, bigQ_module) - interp_bigQ - ([CAst.make @@ GRef (bigQ_z, None)], uninterp_bigQ, - true) diff --git a/plugins/syntax/numbers_syntax_plugin.mlpack b/plugins/syntax/numbers_syntax_plugin.mlpack deleted file mode 100644 index e48c00a0d0..0000000000 --- a/plugins/syntax/numbers_syntax_plugin.mlpack +++ /dev/null @@ -1 +0,0 @@ -Numbers_syntax diff --git a/pretyping/arguments_renaming.ml b/pretyping/arguments_renaming.ml index 1bd03491a7..c7b37aba5c 100644 --- a/pretyping/arguments_renaming.ml +++ b/pretyping/arguments_renaming.ml @@ -43,7 +43,7 @@ let section_segment_of_reference = function | ConstRef con -> Lib.section_segment_of_constant con | IndRef (kn,_) | ConstructRef ((kn,_),_) -> Lib.section_segment_of_mutual_inductive kn - | _ -> [], Univ.LMap.empty, Univ.UContext.empty + | _ -> [], Univ.LMap.empty, Univ.AUContext.empty let discharge_rename_args = function | _, (ReqGlobal (c, names), _ as req) -> diff --git a/pretyping/cases.ml b/pretyping/cases.ml index c3f392980a..b88532e1b9 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -245,6 +245,7 @@ let push_history_pattern n pci cont = type 'a pattern_matching_problem = { env : env; + lvar : Glob_term.ltac_var_map; evdref : evar_map ref; pred : constr; tomatch : tomatch_stack; @@ -346,25 +347,45 @@ let find_tomatch_tycon evdref env loc = function | None -> empty_tycon,None -let coerce_row typing_fun evdref env pats (tomatch,(_,indopt)) = +let make_return_predicate_ltac_lvar sigma na tm c lvar = + match na, tm.CAst.v with + | Name id, (GVar id' | GRef (Globnames.VarRef id', _)) when Id.equal id id' -> + if Id.Map.mem id lvar.ltac_genargs then + let ltac_genargs = Id.Map.remove id lvar.ltac_genargs in + let ltac_idents = match kind sigma c with + | Var id' -> Id.Map.add id id' lvar.ltac_idents + | _ -> lvar.ltac_idents in + { lvar with ltac_genargs; ltac_idents } + else lvar + | _ -> lvar + +let ltac_interp_realnames lvar = function + | t, IsInd (ty,ind,realnal) -> t, IsInd (ty,ind,List.map (ltac_interp_name lvar) realnal) + | _ as x -> x + +let coerce_row typing_fun evdref env lvar pats (tomatch,(na,indopt)) = let loc = loc_of_glob_constr tomatch in let tycon,realnames = find_tomatch_tycon evdref env loc indopt in - let j = typing_fun tycon env evdref tomatch in + let j = typing_fun tycon env evdref !lvar tomatch in let evd, j = Coercion.inh_coerce_to_base ?loc:(loc_of_glob_constr tomatch) env !evdref j in evdref := evd; let typ = nf_evar !evdref j.uj_type in + lvar := make_return_predicate_ltac_lvar !evdref na tomatch j.uj_val !lvar; let t = try try_find_ind env !evdref typ realnames with Not_found -> unify_tomatch_with_patterns evdref env loc typ pats realnames in (j.uj_val,t) -let coerce_to_indtype typing_fun evdref env matx tomatchl = +let coerce_to_indtype typing_fun evdref env lvar matx tomatchl = let pats = List.map (fun r -> r.patterns) matx in let matx' = match matrix_transpose pats with | [] -> List.map (fun _ -> []) tomatchl (* no patterns at all *) | m -> m in - List.map2 (coerce_row typing_fun evdref env) matx' tomatchl + let lvar = ref lvar in + let tms = List.map2 (coerce_row typing_fun evdref env lvar) matx' tomatchl in + let tms = List.map (ltac_interp_realnames !lvar) tms in + !lvar,tms (************************************************************************) (* Utils *) @@ -1392,6 +1413,7 @@ and match_current pb (initial,tomatch) = postprocess_dependencies !(pb.evdref) depstocheck brvals pb.tomatch pb.pred deps cstrs in let brvals = Array.map (fun (sign,body) -> + let sign = List.map (map_name (ltac_interp_name pb.lvar)) sign in it_mkLambda_or_LetIn body sign) brvals in let (pred,typ) = find_predicate pb.caseloc pb.env pb.evdref @@ -1824,6 +1846,7 @@ let build_inversion_problem loc env sigma tms t = let evdref = ref sigma in let pb = { env = pb_env; + lvar = empty_lvar; evdref = evdref; pred = (*ty *) mkSort s; tomatch = sub_tms; @@ -1847,15 +1870,15 @@ let build_initial_predicate arsign pred = | _ -> assert false in buildrec 0 pred [] (List.rev arsign) -let extract_arity_signature ?(dolift=true) env0 tomatchl tmsign = +let extract_arity_signature ?(dolift=true) env0 lvar tomatchl tmsign = let lift = if dolift then lift else fun n t -> t in let get_one_sign n tm (na,t) = match tm with | NotInd (bo,typ) -> (match t with - | None -> (match bo with + | None -> let sign = match bo with | None -> [LocalAssum (na, lift n typ)] - | Some b -> [LocalDef (na, lift n b, lift n typ)]) + | Some b -> [LocalDef (na, lift n b, lift n typ)] in sign,sign | Some (loc,_) -> user_err ?loc (str"Unexpected type annotation for a term of non inductive type.")) @@ -1865,22 +1888,31 @@ let extract_arity_signature ?(dolift=true) env0 tomatchl tmsign = let nrealargs_ctxt = inductive_nrealdecls_env env0 ind in let arsign = fst (get_arity env0 indf') in let arsign = List.map (fun d -> map_rel_decl EConstr.of_constr d) arsign in - let realnal = + let realnal, realnal' = match t with | Some (loc,(ind',realnal)) -> if not (eq_ind ind ind') then user_err ?loc (str "Wrong inductive type."); if not (Int.equal nrealargs_ctxt (List.length realnal)) then anomaly (Pp.str "Ill-formed 'in' clause in cases."); - List.rev realnal - | None -> List.make nrealargs_ctxt Anonymous in - LocalAssum (na, EConstr.of_constr (build_dependent_inductive env0 indf')) - ::(List.map2 RelDecl.set_name realnal arsign) in + let realnal = List.rev realnal in + let realnal' = List.map (ltac_interp_name lvar) realnal in + realnal,realnal' + | None -> + let realnal = List.make nrealargs_ctxt Anonymous in + realnal, realnal in + let na' = ltac_interp_name lvar na in + let t = EConstr.of_constr (build_dependent_inductive env0 indf') in + (* Context with names for typing *) + let arsign1 = LocalAssum (na, t) :: List.map2 RelDecl.set_name realnal arsign in + (* Context with names for building the term *) + let arsign2 = LocalAssum (na', t) :: List.map2 RelDecl.set_name realnal' arsign in + arsign1,arsign2 in let rec buildrec n = function | [],[] -> [] | (_,tm)::ltm, (_,x)::tmsign -> let l = get_one_sign n tm x in - l :: buildrec (n + List.length l) (ltm,tmsign) + l :: buildrec (n + List.length (fst l)) (ltm,tmsign) | _ -> assert false in List.rev (buildrec 0 (tomatchl,tmsign)) @@ -1970,7 +2002,7 @@ let noccur_with_meta sigma n m term = in try (occur_rec n term; true) with LocalOccur -> false -let prepare_predicate ?loc typing_fun env sigma tomatchs arsign tycon pred = +let prepare_predicate ?loc typing_fun env sigma lvar tomatchs arsign tycon pred = let refresh_tycon sigma t = (** If we put the typing constraint in the term, it has to be refreshed to preserve the invariant that no algebraic universe @@ -1978,6 +2010,7 @@ let prepare_predicate ?loc typing_fun env sigma tomatchs arsign tycon pred = refresh_universes ~status:Evd.univ_flexible ~onlyalg:true (Some true) env sigma t in + let typing_arsign,building_arsign = List.split arsign in let preds = match pred, tycon with (* No return clause *) @@ -1987,7 +2020,7 @@ let prepare_predicate ?loc typing_fun env sigma tomatchs arsign tycon pred = (* First strategy: we abstract the tycon wrt to the dependencies *) let sigma, t = refresh_tycon sigma t in let p1 = - prepare_predicate_from_arsign_tycon env sigma loc tomatchs arsign t in + prepare_predicate_from_arsign_tycon env sigma loc tomatchs typing_arsign t in (* Second strategy: we build an "inversion" predicate *) let sigma2,pred2 = build_inversion_problem loc env sigma tomatchs t in (match p1 with @@ -2006,22 +2039,22 @@ let prepare_predicate ?loc typing_fun env sigma tomatchs arsign tycon pred = (* First strategy: we build an "inversion" predicate *) let sigma1,pred1 = build_inversion_problem loc env sigma tomatchs t in (* Second strategy: we directly use the evar as a non dependent pred *) - let pred2 = lift (List.length (List.flatten arsign)) t in + let pred2 = lift (List.length (List.flatten typing_arsign)) t in [sigma1, pred1; sigma, pred2] (* Some type annotation *) | Some rtntyp, _ -> (* We extract the signature of the arity *) - let envar = List.fold_right push_rel_context arsign env in + let envar = List.fold_right push_rel_context typing_arsign env in let sigma, newt = new_sort_variable univ_flexible_alg sigma in let evdref = ref sigma in - let predcclj = typing_fun (mk_tycon (mkSort newt)) envar evdref rtntyp in + let predcclj = typing_fun (mk_tycon (mkSort newt)) envar evdref lvar rtntyp in let sigma = !evdref in let predccl = nf_evar sigma predcclj.uj_val in [sigma, predccl] in List.map (fun (sigma,pred) -> - let (nal,pred) = build_initial_predicate arsign pred in + let (nal,pred) = build_initial_predicate building_arsign pred in sigma,nal,pred) preds @@ -2441,10 +2474,10 @@ let context_of_arsign l = l ([], 0) in x -let compile_program_cases ?loc style (typing_function, evdref) tycon env +let compile_program_cases ?loc style (typing_function, evdref) tycon env lvar (predopt, tomatchl, eqns) = let typing_fun tycon env = function - | Some t -> typing_function tycon env evdref t + | Some t -> typing_function tycon env evdref lvar t | None -> Evarutil.evd_comb0 use_unit_judge evdref in (* We build the matrix of patterns and right-hand side *) @@ -2452,14 +2485,15 @@ let compile_program_cases ?loc style (typing_function, evdref) tycon env (* We build the vector of terms to match consistently with the *) (* constructors found in patterns *) - let tomatchs = coerce_to_indtype typing_function evdref env matx tomatchl in + let predlvar,tomatchs = coerce_to_indtype typing_function evdref env lvar matx tomatchl in let tycon = valcon_of_tycon tycon in let tomatchs, tomatchs_lets, tycon' = abstract_tomatch env !evdref tomatchs tycon in let env = push_rel_context tomatchs_lets env in let len = List.length eqns in let sign, allnames, signlen, eqs, neqs, args = (* The arity signature *) - let arsign = extract_arity_signature ~dolift:false env tomatchs tomatchl in + let arsign = extract_arity_signature ~dolift:false env predlvar tomatchs tomatchl in + let arsign = List.map fst arsign in (* Because no difference between the arity for typing and the arity for building *) (* Build the dependent arity signature, the equalities which makes the first part of the predicate and their instantiations. *) let avoid = [] in @@ -2522,11 +2556,12 @@ let compile_program_cases ?loc style (typing_function, evdref) tycon env let initial_pushed = List.map (fun x -> Pushed (true,x)) typs' in let typing_function tycon env evdref = function - | Some t -> typing_function tycon env evdref t + | Some t -> typing_function tycon env evdref lvar t | None -> evd_comb0 use_unit_judge evdref in let pb = { env = env; + lvar = lvar; evdref = evdref; pred = pred; tomatch = initial_pushed; @@ -2548,10 +2583,10 @@ let compile_program_cases ?loc style (typing_function, evdref) tycon env (**************************************************************************) (* Main entry of the matching compilation *) -let compile_cases ?loc style (typing_fun, evdref) tycon env (predopt, tomatchl, eqns) = +let compile_cases ?loc style (typing_fun, evdref) tycon env lvar (predopt, tomatchl, eqns) = if predopt == None && Flags.is_program_mode () && Program.is_program_cases () then compile_program_cases ?loc style (typing_fun, evdref) - tycon env (predopt, tomatchl, eqns) + tycon env lvar (predopt, tomatchl, eqns) else (* We build the matrix of patterns and right-hand side *) @@ -2559,15 +2594,15 @@ let compile_cases ?loc style (typing_fun, evdref) tycon env (predopt, tomatchl, (* We build the vector of terms to match consistently with the *) (* constructors found in patterns *) - let tomatchs = coerce_to_indtype typing_fun evdref env matx tomatchl in + let predlvar,tomatchs = coerce_to_indtype typing_fun evdref env lvar matx tomatchl in (* If an elimination predicate is provided, we check it is compatible with the type of arguments to match; if none is provided, we build alternative possible predicates *) - let arsign = extract_arity_signature env tomatchs tomatchl in - let preds = prepare_predicate ?loc typing_fun env !evdref tomatchs arsign tycon predopt in + let arsign = extract_arity_signature env predlvar tomatchs tomatchl in + let preds = prepare_predicate ?loc typing_fun env !evdref predlvar tomatchs arsign tycon predopt in let compile_for_one_predicate (sigma,nal,pred) = (* We push the initial terms to match and push their alias to rhs' envs *) @@ -2598,13 +2633,14 @@ let compile_cases ?loc style (typing_fun, evdref) tycon env (predopt, tomatchl, (* A typing function that provides with a canonical term for absurd cases*) let typing_fun tycon env evdref = function - | Some t -> typing_fun tycon env evdref t + | Some t -> typing_fun tycon env evdref lvar t | None -> evd_comb0 use_unit_judge evdref in let myevdref = ref sigma in let pb = { env = env; + lvar = lvar; evdref = myevdref; pred = pred; tomatch = initial_pushed; diff --git a/pretyping/cases.mli b/pretyping/cases.mli index b16342db4b..4b1fde25a8 100644 --- a/pretyping/cases.mli +++ b/pretyping/cases.mli @@ -39,9 +39,9 @@ val irrefutable : env -> cases_pattern -> bool val compile_cases : ?loc:Loc.t -> case_style -> - (type_constraint -> env -> evar_map ref -> glob_constr -> unsafe_judgment) * evar_map ref -> + (type_constraint -> env -> evar_map ref -> ltac_var_map -> glob_constr -> unsafe_judgment) * evar_map ref -> type_constraint -> - env -> glob_constr option * tomatch_tuples * cases_clauses -> + env -> ltac_var_map -> glob_constr option * tomatch_tuples * cases_clauses -> unsafe_judgment val constr_of_pat : @@ -101,6 +101,7 @@ and pattern_continuation = type 'a pattern_matching_problem = { env : env; + lvar : Glob_term.ltac_var_map; evdref : evar_map ref; pred : constr; tomatch : tomatch_stack; @@ -115,10 +116,14 @@ val compile : 'a pattern_matching_problem -> unsafe_judgment val prepare_predicate : ?loc:Loc.t -> (Evarutil.type_constraint -> - Environ.env -> Evd.evar_map ref -> glob_constr -> unsafe_judgment) -> + Environ.env -> Evd.evar_map ref -> ltac_var_map -> glob_constr -> unsafe_judgment) -> Environ.env -> Evd.evar_map -> + Glob_term.ltac_var_map -> (types * tomatch_type) list -> - rel_context list -> + (rel_context * rel_context) list -> constr option -> glob_constr option -> (Evd.evar_map * Names.name list * constr) list + +val make_return_predicate_ltac_lvar : Evd.evar_map -> Names.name -> + Glob_term.glob_constr -> constr -> Glob_term.ltac_var_map -> Glob_term.ltac_var_map diff --git a/pretyping/classops.ml b/pretyping/classops.ml index 9a973cff55..8d87f6e99c 100644 --- a/pretyping/classops.ml +++ b/pretyping/classops.ml @@ -428,7 +428,7 @@ let automatically_import_coercions = ref false open Goptions let _ = declare_bool_option - { optdepr = false; + { optdepr = true; (* remove in 8.8 *) optname = "automatic import of coercions"; optkey = ["Automatic";"Coercions";"Import"]; optread = (fun () -> !automatically_import_coercions); @@ -454,15 +454,11 @@ let cache_coercion (_, c) = add_coercion_in_graph (xf,is,it) let load_coercion _ o = - if - !automatically_import_coercions || Flags.version_less_or_equal Flags.V8_2 - then + if !automatically_import_coercions then cache_coercion o let open_coercion i o = - if Int.equal i 1 && not - (!automatically_import_coercions || Flags.version_less_or_equal Flags.V8_2) - then + if Int.equal i 1 && not !automatically_import_coercions then cache_coercion o let subst_coercion (subst, c) = diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index 3757ba7e6d..d84363089d 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -350,6 +350,26 @@ let exact_ise_stack2 env evd f sk1 sk2 = ise_stack2 evd (List.rev sk1) (List.rev sk2) else UnifFailure (evd, (* Dummy *) NotSameHead) +let check_leq_inductives evd cumi u u' = + let u = EConstr.EInstance.kind evd u in + let u' = EConstr.EInstance.kind evd u' in + let length_ind_instance = + Univ.Instance.length + (Univ.AUContext.instance (Univ.ACumulativityInfo.univ_context cumi)) + in + let ind_sbcst = Univ.ACumulativityInfo.subtyp_context cumi in + if not ((length_ind_instance = Univ.Instance.length u) && + (length_ind_instance = Univ.Instance.length u')) then + anomaly (Pp.str "Invalid inductive subtyping encountered!") + else + begin + let comp_subst = (Univ.Instance.append u u') in + let comp_cst = + Univ.UContext.constraints (Univ.subst_instance_context comp_subst ind_sbcst) + in + Evd.add_constraints evd comp_cst + end + let rec evar_conv_x ts env evd pbty term1 term2 = let term1 = whd_head_evar evd term1 in let term2 = whd_head_evar evd term2 in @@ -439,16 +459,102 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty else evar_eqappr_x ts env' evd CONV out2 out1 in let rigids env evd sk term sk' term' = - let univs = EConstr.eq_constr_universes evd term term' in - match univs with - | Some univs -> - ise_and evd [(fun i -> - let cstrs = Universes.to_constraints (Evd.universes i) univs in - try Success (Evd.add_constraints i cstrs) - with Univ.UniverseInconsistency p -> UnifFailure (i, UnifUnivInconsistency p)); - (fun i -> exact_ise_stack2 env i (evar_conv_x ts) sk sk')] - | None -> - UnifFailure (evd,NotSameHead) + let check_strict () = + let univs = EConstr.eq_constr_universes evd term term' in + match univs with + | Some univs -> + begin + let cstrs = Universes.to_constraints (Evd.universes evd) univs in + try Success (Evd.add_constraints evd cstrs) + with Univ.UniverseInconsistency p -> UnifFailure (evd, UnifUnivInconsistency p) + end + | None -> + UnifFailure (evd, NotSameHead) + in + let first_try_strict_check cond u u' try_subtyping_constraints = + if cond then + let univs = EConstr.eq_constr_universes evd term term' in + match univs with + | Some univs -> + begin + let cstrs = Universes.to_constraints (Evd.universes evd) univs in + try Success (Evd.add_constraints evd cstrs) + with Univ.UniverseInconsistency p -> try_subtyping_constraints () + end + | None -> + UnifFailure (evd, NotSameHead) + else + UnifFailure (evd, NotSameHead) + in + let compare_heads evd = + match EConstr.kind evd term, EConstr.kind evd term' with + | Const (c, u), Const (c', u') -> + check_strict () + | Ind (ind, u), Ind (ind', u') -> + let check_subtyping_constraints () = + let nparamsaplied = Stack.args_size sk in + let nparamsaplied' = Stack.args_size sk' in + begin + let mind = Environ.lookup_mind (fst ind) env in + match mind.Declarations.mind_universes with + | Declarations.Monomorphic_ind _ | Declarations.Polymorphic_ind _ -> + UnifFailure (evd, NotSameHead) + | Declarations.Cumulative_ind cumi -> + begin + let num_param_arity = + mind.Declarations.mind_nparams + + mind.Declarations.mind_packets.(snd ind).Declarations.mind_nrealargs + in + if not (num_param_arity = nparamsaplied + && num_param_arity = nparamsaplied') then + UnifFailure (evd, NotSameHead) + else + begin + let evd' = check_leq_inductives evd cumi u u' in + Success (check_leq_inductives evd' cumi u' u) + end + end + end + in + first_try_strict_check (Names.eq_ind ind ind') u u' check_subtyping_constraints + | Construct (cons, u), Construct (cons', u') -> + let check_subtyping_constraints () = + let ind, ind' = fst cons, fst cons' in + let j, j' = snd cons, snd cons' in + let nparamsaplied = Stack.args_size sk in + let nparamsaplied' = Stack.args_size sk' in + let mind = Environ.lookup_mind (fst ind) env in + match mind.Declarations.mind_universes with + | Declarations.Monomorphic_ind _ | Declarations.Polymorphic_ind _ -> + UnifFailure (evd, NotSameHead) + | Declarations.Cumulative_ind cumi -> + begin + let num_cnstr_args = + let nparamsctxt = + mind.Declarations.mind_nparams + + mind.Declarations.mind_packets.(snd ind).Declarations.mind_nrealargs + in + nparamsctxt + + mind.Declarations.mind_packets.(snd ind). + Declarations.mind_consnrealargs.(j - 1) + in + if not (num_cnstr_args = nparamsaplied + && num_cnstr_args = nparamsaplied') then + UnifFailure (evd, NotSameHead) + else + begin + let evd' = check_leq_inductives evd cumi u u' in + Success (check_leq_inductives evd' cumi u' u) + end + end + in + first_try_strict_check (Names.eq_constructor cons cons') u u' check_subtyping_constraints + | _, _ -> anomaly (Pp.str "") + in + ise_and evd [(fun i -> + try compare_heads i + with Univ.UniverseInconsistency p -> UnifFailure (i, UnifUnivInconsistency p)); + (fun i -> exact_ise_stack2 env i (evar_conv_x ts) sk sk')] in let flex_maybeflex on_left ev ((termF,skF as apprF),cstsF) ((termM, skM as apprM),cstsM) vM = let switch f a b = if on_left then f a b else f b a in diff --git a/pretyping/glob_ops.ml b/pretyping/glob_ops.ml index 62ff9ac708..9c09396ccc 100644 --- a/pretyping/glob_ops.ml +++ b/pretyping/glob_ops.ml @@ -504,3 +504,27 @@ let glob_constr_of_closed_cases_pattern = function na,glob_constr_of_closed_cases_pattern_aux (CAst.make ?loc @@ PatCstr (cstr,l,Anonymous)) | _ -> raise Not_found + +(**********************************************************************) +(* Interpreting ltac variables *) + +open Pp +open CErrors + +let ltac_interp_name { ltac_idents ; ltac_genargs } = function + | Anonymous -> Anonymous + | Name id as n -> + try Name (Id.Map.find id ltac_idents) + with Not_found -> + if Id.Map.mem id ltac_genargs then + user_err (str"Ltac variable"++spc()++ pr_id id ++ + spc()++str"is not bound to an identifier."++spc()++ + str"It cannot be used in a binder.") + else n + +let empty_lvar : ltac_var_map = { + ltac_constrs = Id.Map.empty; + ltac_uconstrs = Id.Map.empty; + ltac_idents = Id.Map.empty; + ltac_genargs = Id.Map.empty; +} diff --git a/pretyping/glob_ops.mli b/pretyping/glob_ops.mli index 75db04f77f..6bb421e732 100644 --- a/pretyping/glob_ops.mli +++ b/pretyping/glob_ops.mli @@ -83,3 +83,6 @@ val cases_pattern_of_glob_constr : Name.t -> glob_constr -> cases_pattern val glob_constr_of_closed_cases_pattern : cases_pattern -> Name.t * glob_constr val add_patterns_for_params_remove_local_defs : constructor -> cases_pattern list -> cases_pattern list + +val ltac_interp_name : Glob_term.ltac_var_map -> Names.name -> Names.name +val empty_lvar : Glob_term.ltac_var_map diff --git a/pretyping/inductiveops.ml b/pretyping/inductiveops.ml index d8252ea9bb..2ae7c0f809 100644 --- a/pretyping/inductiveops.ml +++ b/pretyping/inductiveops.ml @@ -655,3 +655,93 @@ let control_only_guard env c = iter_constr_with_full_binders push_rel iter env c in iter env c + +(* inference of subtyping condition for inductive types *) + +let infer_inductive_subtyping_arity_constructor + (env, evd, csts) (subst : constr -> constr) (arcn : Term.types) is_arity (params : Context.Rel.t) = + let numchecked = ref 0 in + let numparams = Context.Rel.nhyps params in + let update_contexts (env, evd, csts) csts' = + (Environ.add_constraints csts' env, Evd.add_constraints evd csts', Univ.Constraint.union csts csts') + in + let basic_check (env, evd, csts) tp = + let result = + if !numchecked >= numparams then + let csts' = + Reduction.infer_conv_leq ~evars:(Evd.existential_opt_value evd) env (Evd.universes evd) tp (subst tp) + in update_contexts (env, evd, csts) csts' + else + (env, evd, csts) + in + numchecked := !numchecked + 1; result + in + let infer_typ typ ctxs = + match typ with + | LocalAssum (_, typ') -> + begin + try + let (env, evd, csts) = basic_check ctxs typ' in (Environ.push_rel typ env, evd, csts) + with Reduction.NotConvertible -> + anomaly ~label:"inference of record/inductive subtyping relation failed" + (Pp.str "Can't infer subtyping for record/inductive type") + end + | _ -> anomaly (Pp.str "") + in + let arcn' = Term.it_mkProd_or_LetIn arcn params in + let typs, codom = Reduction.dest_prod env arcn' in + let last_contexts = Context.Rel.fold_outside infer_typ typs ~init:(env, evd, csts) in + if not is_arity then basic_check last_contexts codom else last_contexts + +let infer_inductive_subtyping env evd mind_ent = + let { Entries.mind_entry_params = params; + Entries.mind_entry_inds = entries; + Entries.mind_entry_universes = ground_univs; + } = mind_ent + in + let uinfind = + match ground_univs with + | Entries.Monomorphic_ind_entry _ + | Entries.Polymorphic_ind_entry _ -> ground_univs + | Entries.Cumulative_ind_entry cumi -> + begin + let uctx = Univ.CumulativityInfo.univ_context cumi in + let sbsubst = Univ.CumulativityInfo.subtyping_susbst cumi in + let dosubst = subst_univs_level_constr sbsubst in + let instance_other = + Univ.subst_univs_level_instance sbsubst (Univ.UContext.instance uctx) + in + let constraints_other = + Univ.subst_univs_level_constraints + sbsubst (Univ.UContext.constraints uctx) + in + let uctx_other = Univ.UContext.make (instance_other, constraints_other) in + let env = Environ.push_context uctx env in + let env = Environ.push_context uctx_other env in + let evd = + Evd.merge_universe_context + evd (UState.of_context_set (Univ.ContextSet.of_context uctx_other)) + in + let (_, _, subtyp_constraints) = + List.fold_left + (fun ctxs indentry -> + let _, params = Typeops.infer_local_decls env params in + let ctxs' = infer_inductive_subtyping_arity_constructor + ctxs dosubst indentry.Entries.mind_entry_arity true params + in + List.fold_left + (fun ctxs cons -> + infer_inductive_subtyping_arity_constructor + ctxs dosubst cons false params + ) + ctxs' indentry.Entries.mind_entry_lc + ) (env, evd, Univ.Constraint.empty) entries + in + Entries.Cumulative_ind_entry + (Univ.CumulativityInfo.make + (Univ.CumulativityInfo.univ_context cumi, + Univ.UContext.make + (Univ.UContext.instance (Univ.CumulativityInfo.subtyp_context cumi), + subtyp_constraints))) + end + in {mind_ent with Entries.mind_entry_universes = uinfind;} diff --git a/pretyping/inductiveops.mli b/pretyping/inductiveops.mli index bdb6f996b9..811f47f39a 100644 --- a/pretyping/inductiveops.mli +++ b/pretyping/inductiveops.mli @@ -199,3 +199,12 @@ val type_of_inductive_knowing_conclusion : (********************) val control_only_guard : env -> types -> unit + +(* inference of subtyping condition for inductive types *) +(* for debugging purposes only to be removed *) +val infer_inductive_subtyping_arity_constructor : Environ.env * Evd.evar_map * Univ.Constraint.t -> +(Term.constr -> Term.constr) -> +Term.types -> bool -> Context.Rel.t -> Environ.env * Evd.evar_map * Univ.Constraint.t + +val infer_inductive_subtyping : Environ.env -> Evd.evar_map -> Entries.mutual_inductive_entry -> + Entries.mutual_inductive_entry diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index 92e728683d..7488f35bfe 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -42,21 +42,11 @@ open Pretype_errors open Glob_term open Glob_ops open Evarconv -open Pattern open Misctypes module NamedDecl = Context.Named.Declaration type typing_constraint = OfType of types | IsType | WithoutTypeConstraint -type var_map = constr_under_binders Id.Map.t -type uconstr_var_map = Glob_term.closed_glob_constr Id.Map.t -type unbound_ltac_var_map = Geninterp.Val.t Id.Map.t -type ltac_var_map = { - ltac_constrs : var_map; - ltac_uconstrs : uconstr_var_map; - ltac_idents: Id.t Id.Map.t; - ltac_genargs : unbound_ltac_var_map; -} type glob_constr_ltac_closure = ltac_var_map * glob_constr type pure_open_constr = evar_map * EConstr.constr @@ -419,17 +409,6 @@ let orelse_name name name' = match name with | Anonymous -> name' | _ -> name -let ltac_interp_name { ltac_idents ; ltac_genargs } = function - | Anonymous -> Anonymous - | Name id as n -> - try Name (Id.Map.find id ltac_idents) - with Not_found -> - if Id.Map.mem id ltac_genargs then - user_err (str"Ltac variable"++spc()++ pr_id id ++ - spc()++str"is not bound to an identifier."++spc()++ - str"It cannot be used in a binder.") - else n - let ltac_interp_name_env k0 lvar env sigma = (* envhd is the initial part of the env when pretype was called first *) (* (in practice is is probably 0, but we have to grant the @@ -943,16 +922,20 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre List.map (set_name Anonymous) arsgn else arsgn in - let psign = LocalAssum (na, build_dependent_inductive env.ExtraEnv.env indf) :: arsgn in + let indt = build_dependent_inductive env.ExtraEnv.env indf in + let psign = LocalAssum (na, indt) :: arsgn in (* For locating names in [po] *) + let predlvar = Cases.make_return_predicate_ltac_lvar !evdref na c cj.uj_val lvar in + let psign' = LocalAssum (ltac_interp_name predlvar na, indt) :: arsgn in + let psign' = List.map (fun d -> map_rel_decl EConstr.of_constr d) psign' in + let psign' = Namegen.name_context env.ExtraEnv.env !evdref psign' in (* For naming abstractions in [po] *) let psign = List.map (fun d -> map_rel_decl EConstr.of_constr d) psign in let nar = List.length arsgn in (match po with | Some p -> let env_p = push_rel_context !evdref psign env in - let pj = pretype_type empty_valcon env_p evdref lvar p in + let pj = pretype_type empty_valcon env_p evdref predlvar p in let ccl = nf_evar !evdref pj.utj_val in - let psign = make_arity_signature env.ExtraEnv.env !evdref true indf in (* with names *) - let p = it_mkLambda_or_LetIn ccl psign in + let p = it_mkLambda_or_LetIn ccl psign' in let inst = (Array.map_to_list EConstr.of_constr cs.cs_concl_realargs) @[EConstr.of_constr (build_dependent_constructor cs)] in @@ -968,7 +951,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre | None -> let tycon = lift_tycon cs.cs_nargs tycon in - let fj = pretype tycon env_f evdref lvar d in + let fj = pretype tycon env_f evdref predlvar d in let ccl = nf_evar !evdref fj.uj_type in let ccl = if noccur_between !evdref 1 cs.cs_nargs ccl then @@ -977,7 +960,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre error_cant_find_case_type ?loc env.ExtraEnv.env !evdref cj.uj_val in (* let ccl = refresh_universes ccl in *) - let p = it_mkLambda_or_LetIn (lift (nar+1) ccl) psign in + let p = it_mkLambda_or_LetIn (lift (nar+1) ccl) psign' in let v = let ind,_ = dest_ind_family indf in Typing.check_allowed_sort env.ExtraEnv.env !evdref ind cj.uj_val p; @@ -1004,14 +987,19 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre else arsgn in let nar = List.length arsgn in - let psign = LocalAssum (na, build_dependent_inductive env.ExtraEnv.env indf) :: arsgn in + let indt = build_dependent_inductive env.ExtraEnv.env indf in + let psign = LocalAssum (na, indt) :: arsgn in (* For locating names in [po] *) + let predlvar = Cases.make_return_predicate_ltac_lvar !evdref na c cj.uj_val lvar in + let psign' = LocalAssum (ltac_interp_name predlvar na, indt) :: arsgn in + let psign' = List.map (fun d -> map_rel_decl EConstr.of_constr d) psign' in + let psign' = Namegen.name_context env.ExtraEnv.env !evdref psign' in (* For naming abstractions in [po] *) let psign = List.map (fun d -> map_rel_decl EConstr.of_constr d) psign in let pred,p = match po with | Some p -> let env_p = push_rel_context !evdref psign env in - let pj = pretype_type empty_valcon env_p evdref lvar p in + let pj = pretype_type empty_valcon env_p evdref predlvar p in let ccl = nf_evar !evdref pj.utj_val in - let pred = it_mkLambda_or_LetIn ccl psign in + let pred = it_mkLambda_or_LetIn ccl psign' in let typ = lift (- nar) (beta_applist !evdref (pred,[cj.uj_val])) in pred, typ | None -> @@ -1021,7 +1009,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre let env = ltac_interp_name_env k0 lvar env !evdref in new_type_evar env evdref loc in - it_mkLambda_or_LetIn (lift (nar+1) p) psign, p in + it_mkLambda_or_LetIn (lift (nar+1) p) psign', p in let pred = nf_evar !evdref pred in let p = nf_evar !evdref p in let f cs b = @@ -1054,8 +1042,8 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre | GCases (sty,po,tml,eqns) -> Cases.compile_cases ?loc sty - ((fun vtyc env evdref -> pretype vtyc (make_env env !evdref) evdref lvar),evdref) - tycon env.ExtraEnv.env (* loc *) (po,tml,eqns) + ((fun vtyc env evdref -> pretype vtyc (make_env env !evdref) evdref),evdref) + tycon env.ExtraEnv.env (* loc *) lvar (po,tml,eqns) | GCast (c,k) -> let cj = @@ -1198,13 +1186,6 @@ let no_classes_no_fail_inference_flags = { let all_and_fail_flags = default_inference_flags true let all_no_fail_flags = default_inference_flags false -let empty_lvar : ltac_var_map = { - ltac_constrs = Id.Map.empty; - ltac_uconstrs = Id.Map.empty; - ltac_idents = Id.Map.empty; - ltac_genargs = Id.Map.empty; -} - let on_judgment sigma f j = let c = mkCast(j.uj_val,DEFAULTcast, j.uj_type) in let (c,_,t) = destCast sigma (f c) in diff --git a/pretyping/pretyping.mli b/pretyping/pretyping.mli index dcacd07209..e17468ef83 100644 --- a/pretyping/pretyping.mli +++ b/pretyping/pretyping.mli @@ -12,7 +12,6 @@ into elementary ones, insertion of coercions and resolution of implicit arguments. *) -open Names open Term open Environ open Evd @@ -28,23 +27,6 @@ val search_guard : type typing_constraint = OfType of types | IsType | WithoutTypeConstraint -type var_map = Pattern.constr_under_binders Id.Map.t -type uconstr_var_map = Glob_term.closed_glob_constr Id.Map.t -type unbound_ltac_var_map = Geninterp.Val.t Id.Map.t - -type ltac_var_map = { - ltac_constrs : var_map; - (** Ltac variables bound to constrs *) - ltac_uconstrs : uconstr_var_map; - (** Ltac variables bound to untyped constrs *) - ltac_idents: Id.t Id.Map.t; - (** Ltac variables bound to identifiers *) - ltac_genargs : unbound_ltac_var_map; - (** Ltac variables bound to other kinds of arguments *) -} - -val empty_lvar : ltac_var_map - type glob_constr_ltac_closure = ltac_var_map * glob_constr type pure_open_constr = evar_map * constr diff --git a/pretyping/recordops.ml b/pretyping/recordops.ml index bc9e3a1f46..283a1dcd18 100644 --- a/pretyping/recordops.ml +++ b/pretyping/recordops.ml @@ -197,7 +197,7 @@ let warn_projection_no_head_constant = (* Intended to always succeed *) let compute_canonical_projections warn (con,ind) = let env = Global.env () in - let ctx = Univ.instantiate_univ_context (Environ.constant_context env con) in + let ctx = Environ.constant_context env con in let u = Univ.UContext.instance ctx in let v = (mkConstU (con,u)) in let ctx = Univ.ContextSet.of_context ctx in @@ -298,8 +298,7 @@ let error_not_structure ref = let check_and_decompose_canonical_structure ref = let sp = match ref with ConstRef sp -> sp | _ -> error_not_structure ref in let env = Global.env () in - let ctx = Environ.constant_context env sp in - let u = Univ.UContext.instance ctx in + let u = Environ.constant_instance env sp in let vc = match Environ.constant_opt_value_in env (sp, u) with | Some vc -> vc | None -> error_not_structure ref in diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml index c2a6483012..123c610166 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -1313,8 +1313,8 @@ let pb_equal = function | Reduction.CUMUL -> Reduction.CONV | Reduction.CONV -> Reduction.CONV -let report_anomaly _ = - let e = UserError (None, Pp.str "Conversion test raised an anomaly") in +let report_anomaly e = + let e = UserError (None, Pp.(str "Conversion test raised an anomaly" ++ print e)) in let e = CErrors.push e in iraise e @@ -1361,9 +1361,81 @@ let sigma_compare_instances ~flex i0 i1 sigma = | Univ.UniverseInconsistency _ -> raise Reduction.NotConvertible +let sigma_check_inductive_instances cv_pb uinfind u u' sigma = + let ind_instance = + Univ.AUContext.instance (Univ.ACumulativityInfo.univ_context uinfind) + in + let ind_sbctx = Univ.ACumulativityInfo.subtyp_context uinfind in + if not ((Univ.Instance.length ind_instance = Univ.Instance.length u) && + (Univ.Instance.length ind_instance = Univ.Instance.length u')) then + anomaly (Pp.str "Invalid inductive subtyping encountered!") + else + let comp_cst = + let comp_subst = (Univ.Instance.append u u') in + Univ.UContext.constraints (Univ.subst_instance_context comp_subst ind_sbctx) + in + let comp_cst = + match cv_pb with + Reduction.CONV -> + let comp_subst = (Univ.Instance.append u' u) in + let comp_cst' = + Univ.UContext.constraints(Univ.subst_instance_context comp_subst ind_sbctx) + in + Univ.Constraint.union comp_cst comp_cst' + | Reduction.CUMUL -> comp_cst + in + try Evd.add_constraints sigma comp_cst + with Evd.UniversesDiffer + | Univ.UniverseInconsistency _ -> + raise Reduction.NotConvertible + +let sigma_conv_inductives + cv_pb (mind, ind) u1 sv1 u2 sv2 sigma = + try sigma_compare_instances ~flex:false u1 u2 sigma with + Reduction.NotConvertible -> + match mind.Declarations.mind_universes with + | Declarations.Monomorphic_ind _ -> + raise Reduction.NotConvertible + | Declarations.Polymorphic_ind _ -> + raise Reduction.NotConvertible + | Declarations.Cumulative_ind cumi -> + let num_param_arity = + mind.Declarations.mind_nparams + + mind.Declarations.mind_packets.(ind).Declarations.mind_nrealargs + in + if not (num_param_arity = sv1 && num_param_arity = sv2) then + raise Reduction.NotConvertible + else + sigma_check_inductive_instances cv_pb cumi u1 u2 sigma + +let sigma_conv_constructors + (mind, ind, cns) u1 sv1 u2 sv2 sigma = + try sigma_compare_instances ~flex:false u1 u2 sigma with + Reduction.NotConvertible -> + match mind.Declarations.mind_universes with + | Declarations.Monomorphic_ind _ -> + raise Reduction.NotConvertible + | Declarations.Polymorphic_ind _ -> + raise Reduction.NotConvertible + | Declarations.Cumulative_ind cumi -> + let num_cnstr_args = + let nparamsctxt = + mind.Declarations.mind_nparams + + mind.Declarations.mind_packets.(ind).Declarations.mind_nrealargs + in + nparamsctxt + + mind.Declarations.mind_packets.(ind).Declarations.mind_consnrealargs.(cns - 1) + in + if not (num_cnstr_args = sv1 && num_cnstr_args = sv2) then + raise Reduction.NotConvertible + else + sigma_check_inductive_instances Reduction.CONV cumi u1 u2 sigma + let sigma_univ_state = { Reduction.compare = sigma_compare_sorts; - Reduction.compare_instances = sigma_compare_instances } + Reduction.compare_instances = sigma_compare_instances; + Reduction.conv_inductives = sigma_conv_inductives; + Reduction.conv_constructors = sigma_conv_constructors} let infer_conv_gen conv_fun ?(catch_incon=true) ?(pb=Reduction.CUMUL) ?(ts=full_transparent_state) env sigma x y = diff --git a/pretyping/reductionops.mli b/pretyping/reductionops.mli index af4ea3ac53..a4da19de75 100644 --- a/pretyping/reductionops.mli +++ b/pretyping/reductionops.mli @@ -66,7 +66,6 @@ module Cst_stack : sig val pr : t -> Pp.std_ppcmds end - module Stack : sig type 'a app_node diff --git a/pretyping/typeclasses.ml b/pretyping/typeclasses.ml index d7b4842810..f883e647b5 100644 --- a/pretyping/typeclasses.ml +++ b/pretyping/typeclasses.ml @@ -111,20 +111,16 @@ let new_instance cl info glob poly impl = let classes : typeclasses ref = Summary.ref Refmap.empty ~name:"classes" let instances : instances ref = Summary.ref Refmap.empty ~name:"instances" -open Declarations - let typeclass_univ_instance (cl,u') = let subst = let u = match cl.cl_impl with | ConstRef c -> let cb = Global.lookup_constant c in - if cb.const_polymorphic then Univ.UContext.instance cb.const_universes - else Univ.Instance.empty + Declareops.constant_polymorphic_instance cb | IndRef c -> let mib,oib = Global.lookup_inductive c in - if mib.mind_polymorphic then Univ.UContext.instance mib.mind_universes - else Univ.Instance.empty + Declareops.inductive_polymorphic_instance mib | _ -> Univ.Instance.empty in Array.fold_left2 (fun subst u u' -> Univ.LMap.add u u' subst) Univ.LMap.empty (Univ.Instance.to_array u) (Univ.Instance.to_array u') diff --git a/pretyping/unification.ml b/pretyping/unification.ml index 0fb48ed8cf..67c8b07e78 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -248,24 +248,13 @@ let sort_eqns = unify_r2l let global_pattern_unification_flag = ref true -(* Compatibility option introduced and activated in Coq 8.3 whose - syntax is now deprecated. *) - open Goptions -let _ = - declare_bool_option - { optdepr = true; - optname = "pattern-unification for existential variables in tactics"; - optkey = ["Tactic";"Evars";"Pattern";"Unification"]; - optread = (fun () -> !global_pattern_unification_flag); - optwrite = (:=) global_pattern_unification_flag } -(* Compatibility option superseding the previous one, introduced and - activated in Coq 8.4 *) +(* Compatibility option introduced and activated in Coq 8.4 *) let _ = declare_bool_option - { optdepr = false; + { optdepr = true; (* remove in 8.8 *) optname = "pattern-unification for existential variables in tactics"; optkey = ["Tactic";"Pattern";"Unification"]; optread = (fun () -> !global_pattern_unification_flag); @@ -481,12 +470,10 @@ let set_flags_for_type flags = { flags with let use_evars_pattern_unification flags = !global_pattern_unification_flag && flags.use_pattern_unification - && Flags.version_strictly_greater Flags.V8_2 let use_metas_pattern_unification sigma flags nb l = !global_pattern_unification_flag && flags.use_pattern_unification - || (Flags.version_less_or_equal Flags.V8_3 || - flags.use_meta_bound_pattern_unification) && + || flags.use_meta_bound_pattern_unification && Array.for_all (fun c -> isRel sigma c && destRel sigma c <= nb) l type key = @@ -609,9 +596,6 @@ let do_reduce ts (env, nb) sigma c = Stack.zip sigma (fst (whd_betaiota_deltazeta_for_iota_state ts env sigma Cst_stack.empty (c, Stack.empty))) -let use_full_betaiota flags = - flags.modulo_betaiota && Flags.version_strictly_greater Flags.V8_3 - let isAllowedEvar sigma flags c = match EConstr.kind sigma c with | Evar (evk,_) -> not (Evar.Set.mem evk flags.frozen_evars) | _ -> false @@ -949,7 +933,7 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top e expand curenvnb pb opt substn cM f1 l1 cN f2 l2 and reduce curenvnb pb opt (sigma, metas, evars as substn) cM cN = - if use_full_betaiota flags && not (subterm_restriction opt flags) then + if flags.modulo_betaiota && not (subterm_restriction opt flags) then let cM' = do_reduce flags.modulo_delta curenvnb sigma cM in if not (EConstr.eq_constr sigma cM cM') then unirec_rec curenvnb pb opt substn cM' cN diff --git a/pretyping/vnorm.ml b/pretyping/vnorm.ml index b08666483e..9e151fea25 100644 --- a/pretyping/vnorm.ml +++ b/pretyping/vnorm.ml @@ -174,8 +174,7 @@ and nf_whd env sigma whd typ = | Vatom_stk(Aind ((mi,i) as ind), stk) -> let mib = Environ.lookup_mind mi env in let nb_univs = - if mib.mind_polymorphic then Univ.UContext.size mib.mind_universes - else 0 + Univ.Instance.length (Declareops.inductive_polymorphic_instance mib) in let mk u = let pind = (ind, u) in (mkIndU pind, type_of_ind env pind) @@ -204,8 +203,7 @@ and constr_type_of_idkey env sigma (idkey : Vars.id_key) stk = | ConstKey cst -> let cbody = Environ.lookup_constant cst env in let nb_univs = - if cbody.const_polymorphic then Univ.UContext.size cbody.const_universes - else 0 + Univ.Instance.length (Declareops.constant_polymorphic_instance cbody) in let mk u = let pcst = (cst, u) in (mkConstU pcst, Typeops.type_of_constant_in env pcst) diff --git a/printing/ppconstr.ml b/printing/ppconstr.ml index 626464b96f..49eedb767b 100644 --- a/printing/ppconstr.ml +++ b/printing/ppconstr.ml @@ -80,7 +80,7 @@ let tag_var = tag Tag.variable | Any -> true let prec_of_prim_token = function - | Numeral p -> if Bigint.is_pos_or_zero p then lposint else lnegint + | Numeral (_,b) -> if b then lposint else lnegint | String _ -> latom open Notation @@ -231,7 +231,7 @@ let tag_var = tag Tag.variable | ArgVar (loc,s) -> pr_lident (loc,s) let pr_prim_token = function - | Numeral n -> str (Bigint.to_string n) + | Numeral (n,s) -> str (if s then n else "-"^n) | String s -> qs s let pr_evar pr id l = diff --git a/printing/ppvernac.ml b/printing/ppvernac.ml index 781af47892..4a5cfe6301 100644 --- a/printing/ppvernac.ml +++ b/printing/ppvernac.ml @@ -561,17 +561,13 @@ open Decl_kinds | GoalUid n -> spc () ++ str n in let pr_showable = function | ShowGoal n -> keyword "Show" ++ pr_goal_reference n - | ShowGoalImplicitly n -> keyword "Show Implicit Arguments" ++ pr_opt int n | ShowProof -> keyword "Show Proof" - | ShowNode -> keyword "Show Node" | ShowScript -> keyword "Show Script" | ShowExistentials -> keyword "Show Existentials" | ShowUniverses -> keyword "Show Universes" - | ShowTree -> keyword "Show Tree" | ShowProofNames -> keyword "Show Conjectures" | ShowIntros b -> keyword "Show " ++ (if b then keyword "Intros" else keyword "Intro") | ShowMatch id -> keyword "Show Match " ++ pr_reference id - | ShowThesis -> keyword "Show Thesis" in return (pr_showable s) | VernacCheckGuard -> @@ -731,7 +727,7 @@ open Decl_kinds let assumptions = prlist_with_sep spc (fun p -> hov 1 (str "(" ++ pr_params p ++ str ")")) l in return (hov 2 (pr_assumption_token (n > 1) stre ++ pr_non_empty_arg pr_assumption_inline t ++ spc() ++ assumptions)) - | VernacInductive (p,f,l) -> + | VernacInductive (cum, p,f,l) -> let pr_constructor (coe,(id,c)) = hov 2 (pr_lident id ++ str" " ++ (if coe then str":>" else str":") ++ @@ -758,13 +754,19 @@ open Decl_kinds in let key = let (_,_,_,k,_),_ = List.hd l in - match k with Record -> "Record" | Structure -> "Structure" - | Inductive_kw -> "Inductive" | CoInductive -> "CoInductive" - | Class _ -> "Class" | Variant -> "Variant" + let kind = + match k with Record -> "Record" | Structure -> "Structure" + | Inductive_kw -> "Inductive" | CoInductive -> "CoInductive" + | Class _ -> "Class" | Variant -> "Variant" + in + if p then + let cm = if cum then "Cumulative" else "NonCumulative" in + cm ^ " " ^ kind + else kind in return ( hov 1 (pr_oneind key (List.hd l)) ++ - (prlist (fun ind -> fnl() ++ hov 1 (pr_oneind "with" ind)) (List.tl l)) + (prlist (fun ind -> fnl() ++ hov 1 (pr_oneind "with" ind)) (List.tl l)) ) | VernacFixpoint (local, recs) -> diff --git a/printing/prettyp.ml b/printing/prettyp.ml index 2b21b3f9e8..6d2bf6b73a 100644 --- a/printing/prettyp.ml +++ b/printing/prettyp.ml @@ -502,8 +502,8 @@ let ungeneralized_type_of_constant_type t = Typeops.type_of_constant_type (Global.env ()) t let print_instance sigma cb = - if cb.const_polymorphic then - pr_universe_instance sigma cb.const_universes + if Declareops.constant_is_polymorphic cb then + pr_universe_instance sigma (Declareops.constant_polymorphic_context cb) else mt() let print_constant with_values sep sp = @@ -511,16 +511,14 @@ let print_constant with_values sep sp = let val_0 = Global.body_of_constant_body cb in let typ = Declareops.type_of_constant cb in let typ = ungeneralized_type_of_constant_type typ in - let univs = Univ.instantiate_univ_context - (Global.universes_of_constant_body cb) - in + let univs = Global.universes_of_constant_body cb in let ctx = Evd.evar_universe_context_of_binders (Universes.universe_binders_of_global (ConstRef sp)) in let env = Global.env () and sigma = Evd.from_ctx ctx in let pr_ltype = pr_ltype_env env sigma in - hov 0 (pr_polymorphic cb.const_polymorphic ++ + hov 0 (pr_polymorphic (Declareops.constant_is_polymorphic cb) ++ match val_0 with | None -> str"*** [ " ++ @@ -587,8 +585,6 @@ let gallina_print_library_entry with_values ent = Some (str " >>>>>>> Module " ++ pr_name oname) | (oname,Lib.ClosedModule _) -> Some (str " >>>>>>> Closed Module " ++ pr_name oname) - | (_,Lib.FrozenState _) -> - None let gallina_print_context with_values = let rec prec n = function diff --git a/printing/printer.ml b/printing/printer.ml index 3c31dd96bf..3b0b6d5d23 100644 --- a/printing/printer.ml +++ b/printing/printer.ml @@ -17,7 +17,6 @@ open Nametab open Evd open Proof_type open Refiner -open Pfedit open Constrextern open Ppconstr open Declarations @@ -262,6 +261,14 @@ let pr_universe_ctx sigma c = else mt() +let pr_cumulativity_info sigma cumi = + if !Detyping.print_universes + && not (Univ.UContext.is_empty (Univ.CumulativityInfo.univ_context cumi)) then + fnl()++pr_in_comment (fun uii -> v 0 + (Univ.pr_cumulativity_info (Termops.pr_evd_level sigma) uii)) cumi + else + mt() + (**********************************************************************) (* Global references *) @@ -812,7 +819,7 @@ let pr_open_subgoals ?(proof=Proof_global.give_me_the_proof ()) () = end let pr_nth_open_subgoal n = - let pf = get_pftreestate () in + let pf = Proof_global.give_me_the_proof () in let { it=gls ; sigma=sigma } = Proof.V82.subgoals pf in pr_subgoal n sigma gls @@ -992,6 +999,11 @@ let pr_assumptionset env s = let xor a b = (a && not b) || (not a && b) +let pr_cumulative poly cum = + if poly then + if cum then str "Cumulative " else str "NonCumulative " + else mt () + let pr_polymorphic b = let print = xor (Flags.is_universe_polymorphism ()) b in if print then diff --git a/printing/printer.mli b/printing/printer.mli index 3fce065613..f0a32bbbdf 100644 --- a/printing/printer.mli +++ b/printing/printer.mli @@ -95,8 +95,10 @@ val pr_sort : evar_map -> sorts -> std_ppcmds (** Universe constraints *) val pr_polymorphic : bool -> std_ppcmds +val pr_cumulative : bool -> bool -> std_ppcmds val pr_universe_instance : evar_map -> Univ.universe_context -> std_ppcmds val pr_universe_ctx : evar_map -> Univ.universe_context -> std_ppcmds +val pr_cumulativity_info : evar_map -> Univ.cumulativity_info -> std_ppcmds (** Printing global references using names as short as possible *) diff --git a/printing/printmod.ml b/printing/printmod.ml index c4affd4acd..08d177f53e 100644 --- a/printing/printmod.ml +++ b/printing/printmod.ml @@ -88,8 +88,8 @@ let build_ind_type env mip = Inductive.type_of_inductive env mip let print_one_inductive env sigma mib ((_,i) as ind) = - let u = if mib.mind_polymorphic then - Univ.UContext.instance mib.mind_universes + let u = if Declareops.inductive_is_polymorphic mib then + Declareops.inductive_polymorphic_instance mib else Univ.Instance.empty in let mip = mib.mind_packets.(i) in let params = Inductive.inductive_paramdecls (mib,u) in @@ -99,8 +99,8 @@ let print_one_inductive env sigma mib ((_,i) as ind) = let cstrtypes = Array.map (fun c -> hnf_prod_applist env c args) cstrtypes in let envpar = push_rel_context params env in let inst = - if mib.mind_polymorphic then - Printer.pr_universe_instance sigma mib.mind_universes + if Declareops.inductive_is_polymorphic mib then + Printer.pr_universe_instance sigma (Declareops.inductive_polymorphic_context mib) else mt () in hov 0 ( @@ -120,11 +120,18 @@ let print_mutual_inductive env mind mib = in let bl = Universes.universe_binders_of_global (IndRef (mind, 0)) in let sigma = Evd.from_ctx (Evd.evar_universe_context_of_binders bl) in - hov 0 (Printer.pr_polymorphic mib.mind_polymorphic ++ - def keyword ++ spc () ++ - prlist_with_sep (fun () -> fnl () ++ str" with ") - (print_one_inductive env sigma mib) inds ++ - Printer.pr_universe_ctx sigma (Univ.instantiate_univ_context mib.mind_universes)) + hov 0 (Printer.pr_polymorphic (Declareops.inductive_is_polymorphic mib) ++ + Printer.pr_cumulative + (Declareops.inductive_is_polymorphic mib) + (Declareops.inductive_is_cumulative mib) ++ + def keyword ++ spc () ++ + prlist_with_sep (fun () -> fnl () ++ str" with ") + (print_one_inductive env sigma mib) inds ++ + match mib.mind_universes with + | Monomorphic_ind _ | Polymorphic_ind _ -> str "" + | Cumulative_ind cumi -> + Printer.pr_cumulativity_info + sigma (Univ.instantiate_cumulativity_info cumi)) let get_fields = let rec prodec_rec l subst c = @@ -141,8 +148,8 @@ let get_fields = let print_record env mind mib = let u = - if mib.mind_polymorphic then - Univ.UContext.instance mib.mind_universes + if Declareops.inductive_is_polymorphic mib then + Declareops.inductive_polymorphic_instance mib else Univ.Instance.empty in let mip = mib.mind_packets.(0) in @@ -164,7 +171,10 @@ let print_record env mind mib = in hov 0 ( hov 0 ( - Printer.pr_polymorphic mib.mind_polymorphic ++ + Printer.pr_polymorphic (Declareops.inductive_is_polymorphic mib) ++ + Printer.pr_cumulative + (Declareops.inductive_is_polymorphic mib) + (Declareops.inductive_is_cumulative mib) ++ def keyword ++ spc () ++ pr_id mip.mind_typename ++ brk(1,4) ++ print_params env sigma params ++ str ": " ++ Printer.pr_lconstr_env envpar sigma arity ++ brk(1,2) ++ @@ -175,7 +185,12 @@ let print_record env mind mib = (fun (id,b,c) -> pr_id id ++ str (if b then " : " else " := ") ++ Printer.pr_lconstr_env envpar sigma c) fields) ++ str" }" ++ - Printer.pr_universe_ctx sigma (Univ.instantiate_univ_context mib.mind_universes)) + match mib.mind_universes with + | Monomorphic_ind _ | Polymorphic_ind _ -> str "" + | Cumulative_ind cumi -> + Printer.pr_cumulativity_info + sigma (Univ.instantiate_cumulativity_info cumi) + ) let pr_mutual_inductive_body env mind mib = if mib.mind_record <> None && not !Flags.raw_print then @@ -278,7 +293,8 @@ let print_body is_impl env mp (l,body) = | SFBmodtype _ -> keyword "Module Type" ++ spc () ++ name | SFBconst cb -> let u = - if cb.const_polymorphic then Univ.UContext.instance cb.const_universes + if Declareops.constant_is_polymorphic cb then + Declareops.constant_polymorphic_instance cb else Univ.Instance.empty in let sigma = Evd.empty in @@ -300,7 +316,8 @@ let print_body is_impl env mp (l,body) = Printer.pr_lconstr_env env sigma (Vars.subst_instance_constr u (Mod_subst.force_constr l))) | _ -> mt ()) ++ str "." ++ - Printer.pr_universe_ctx sigma (Univ.instantiate_univ_context cb.const_universes)) + Printer.pr_universe_ctx sigma + (Declareops.constant_polymorphic_context cb)) | SFBmind mib -> try let env = Option.get env in diff --git a/proofs/pfedit.ml b/proofs/pfedit.ml index 3fb66d1b87..b28234a504 100644 --- a/proofs/pfedit.ml +++ b/proofs/pfedit.ml @@ -24,19 +24,6 @@ let _ = Goptions.declare_bool_option { let use_unification_heuristics () = !use_unification_heuristics_ref -let refining = Proof_global.there_are_pending_proofs -let check_no_pending_proofs = Proof_global.check_no_pending_proof - -let get_current_proof_name = Proof_global.get_current_proof_name -let get_all_proof_names = Proof_global.get_all_proof_names - -type lemma_possible_guards = Proof_global.lemma_possible_guards -type universe_binders = Proof_global.universe_binders - -let delete_proof = Proof_global.discard -let delete_current_proof = Proof_global.discard_current -let delete_all_proofs = Proof_global.discard_all - let start_proof (id : Id.t) ?pl str sigma hyps c ?init_tac terminator = let goals = [ (Global.env_of_context hyps , c) ] in Proof_global.start_proof sigma id ?pl str goals terminator; @@ -55,32 +42,20 @@ let cook_this_proof p = let cook_proof () = cook_this_proof (fst (Proof_global.close_proof ~keep_body_ucst_separate:false (fun x -> x))) -let get_pftreestate () = - Proof_global.give_me_the_proof () - -let set_end_tac tac = - Proof_global.set_endline_tactic tac - -let set_used_variables l = - Proof_global.set_used_variables l -let get_used_variables () = - Proof_global.get_used_variables () - -let get_universe_binders () = - Proof_global.get_universe_binders () exception NoSuchGoal let _ = CErrors.register_handler begin function | NoSuchGoal -> CErrors.user_err Pp.(str "No such goal.") | _ -> raise CErrors.Unhandled end + let get_nth_V82_goal i = let p = Proof_global.give_me_the_proof () in let { it=goals ; sigma = sigma; } = Proof.V82.subgoals p in try { it=(List.nth goals (i-1)) ; sigma=sigma; } with Failure _ -> raise NoSuchGoal - + let get_goal_context_gen i = let { it=goal ; sigma=sigma; } = get_nth_V82_goal i in (sigma, Refiner.pf_env { it=goal ; sigma=sigma; }) @@ -106,7 +81,7 @@ let get_current_context () = (Evd.from_env env, env) | NoSuchGoal -> (* No more focused goals ? *) - let p = get_pftreestate () in + let p = Proof_global.give_me_the_proof () in let evd = Proof.in_proof p (fun x -> x) in (evd, Global.env ()) @@ -165,11 +140,11 @@ let build_constant_by_tactic id ctx sign ?(goal_kind = Global, false, Proof Theo try let status = by tac in let _,(const,univs,_) = cook_proof () in - delete_current_proof (); + Proof_global.discard_current (); const, status, fst univs with reraise -> let reraise = CErrors.push reraise in - delete_current_proof (); + Proof_global.discard_current (); iraise reraise let build_by_tactic ?(side_eff=true) env sigma ?(poly=false) typ tac = @@ -257,4 +232,32 @@ let solve_by_implicit_tactic () = match !implicit_tactic with | None -> None | Some tac -> Some (apply_implicit_tactic tac) +(** Deprecated functions *) +let refining = Proof_global.there_are_pending_proofs +let check_no_pending_proofs = Proof_global.check_no_pending_proof + +let get_current_proof_name = Proof_global.get_current_proof_name +let get_all_proof_names = Proof_global.get_all_proof_names + +type lemma_possible_guards = Proof_global.lemma_possible_guards +type universe_binders = Proof_global.universe_binders + +let delete_proof = Proof_global.discard +let delete_current_proof = Proof_global.discard_current +let delete_all_proofs = Proof_global.discard_all + +let get_pftreestate () = + Proof_global.give_me_the_proof () + +let set_end_tac tac = + Proof_global.set_endline_tactic tac + +let set_used_variables l = + Proof_global.set_used_variables l + +let get_used_variables () = + Proof_global.get_used_variables () + +let get_universe_binders () = + Proof_global.get_universe_binders () diff --git a/proofs/pfedit.mli b/proofs/pfedit.mli index 1bf65b8aed..f009593e98 100644 --- a/proofs/pfedit.mli +++ b/proofs/pfedit.mli @@ -14,39 +14,6 @@ open Term open Environ open Decl_kinds -(** Several proofs can be opened simultaneously but at most one is - focused at some time. The following functions work by side-effect - on current set of open proofs. In this module, ``proofs'' means an - open proof (something started by vernacular command [Goal], [Lemma] - or [Theorem]), and ``goal'' means a subgoal of the current focused - proof *) - -(** {6 ... } *) -(** [refining ()] tells if there is some proof in progress, even if a not - focused one *) - -val refining : unit -> bool - -(** [check_no_pending_proofs ()] fails if there is still some proof in - progress *) - -val check_no_pending_proofs : unit -> unit - -(** {6 ... } *) -(** [delete_proof name] deletes proof of name [name] or fails if no proof - has this name *) - -val delete_proof : Id.t located -> unit - -(** [delete_current_proof ()] deletes current focused proof or fails if - no proof is focused *) - -val delete_current_proof : unit -> unit - -(** [delete_all_proofs ()] deletes all open proofs if any *) - -val delete_all_proofs : unit -> unit - (** {6 ... } *) (** [start_proof s str env t hook tac] starts a proof of name [s] and conclusion [t]; [hook] is optionally a function to be applied at @@ -55,12 +22,8 @@ val delete_all_proofs : unit -> unit systematically apply at initialization time (e.g. to start the proof of mutually dependent theorems) *) -type lemma_possible_guards = Proof_global.lemma_possible_guards - -type universe_binders = Id.t Loc.located list - val start_proof : - Id.t -> ?pl:universe_binders -> goal_kind -> Evd.evar_map -> named_context_val -> EConstr.constr -> + Id.t -> ?pl:Proof_global.universe_binders -> goal_kind -> Evd.evar_map -> named_context_val -> EConstr.constr -> ?init_tac:unit Proofview.tactic -> Proof_global.proof_terminator -> unit @@ -80,11 +43,6 @@ val cook_proof : unit -> (Safe_typing.private_constants Entries.definition_entry * Proof_global.proof_universes * goal_kind)) (** {6 ... } *) -(** [get_pftreestate ()] returns the current focused pending proof. - @raise NoCurrentProof if there is no pending proof. *) - -val get_pftreestate : unit -> Proof.proof - (** [get_goal_context n] returns the context of the [n]th subgoal of the current focused proof or raises a [UserError] if there is no focused proof or if there is no more subgoals *) @@ -109,34 +67,6 @@ val current_proof_statement : unit -> Id.t * goal_kind * EConstr.types (** {6 ... } *) -(** [get_current_proof_name ()] return the name of the current focused - proof or failed if no proof is focused *) - -val get_current_proof_name : unit -> Id.t - -(** [get_all_proof_names ()] returns the list of all pending proof names. - The first name is the current proof, the other names may come in - any order. *) - -val get_all_proof_names : unit -> Id.t list - -(** {6 ... } *) -(** [set_end_tac tac] applies tactic [tac] to all subgoal generate - by [solve] *) - -val set_end_tac : Genarg.glob_generic_argument -> unit - -(** {6 ... } *) -(** [set_used_variables l] declares that section variables [l] will be - used in the proof *) -val set_used_variables : - Id.t list -> Context.Named.t * Names.Id.t Loc.located list -val get_used_variables : unit -> Context.Named.t option - -(** {6 Universe binders } *) -val get_universe_binders : unit -> universe_binders option - -(** {6 ... } *) (** [solve (SelectNth n) tac] applies tactic [tac] to the [n]th subgoal of the current focused proof or raises a [UserError] if no proof is focused or if there is no [n]th subgoal. [solve SelectAll @@ -191,3 +121,88 @@ val clear_implicit_tactic : unit -> unit (* Raise Exit if cannot solve *) val solve_by_implicit_tactic : unit -> Pretyping.inference_hook option + +(** {5 Deprecated functions in favor of [Proof_global]} *) + +(** {6 ... } *) +(** Several proofs can be opened simultaneously but at most one is + focused at some time. The following functions work by side-effect + on current set of open proofs. In this module, ``proofs'' means an + open proof (something started by vernacular command [Goal], [Lemma] + or [Theorem]), and ``goal'' means a subgoal of the current focused + proof *) + +(** [refining ()] tells if there is some proof in progress, even if a not + focused one *) + +val refining : unit -> bool +[@@ocaml.deprecated "use Proof_global.there_are_pending_proofs"] + +(** [check_no_pending_proofs ()] fails if there is still some proof in + progress *) + +val check_no_pending_proofs : unit -> unit +[@@ocaml.deprecated "use Proof_global.check_no_pending_proofs"] + +(** {6 ... } *) +(** [delete_proof name] deletes proof of name [name] or fails if no proof + has this name *) + +val delete_proof : Id.t located -> unit +[@@ocaml.deprecated "use Proof_global.discard"] + +(** [delete_current_proof ()] deletes current focused proof or fails if + no proof is focused *) + +val delete_current_proof : unit -> unit +[@@ocaml.deprecated "use Proof_global.discard_current"] + +(** [delete_all_proofs ()] deletes all open proofs if any *) +val delete_all_proofs : unit -> unit +[@@ocaml.deprecated "use Proof_global.discard_all"] + +(** [get_pftreestate ()] returns the current focused pending proof. + @raise NoCurrentProof if there is no pending proof. *) + +val get_pftreestate : unit -> Proof.proof +[@@ocaml.deprecated "use Proof_global.give_me_the_proof"] + +(** {6 ... } *) +(** [set_end_tac tac] applies tactic [tac] to all subgoal generate + by [solve] *) + +val set_end_tac : Genarg.glob_generic_argument -> unit +[@@ocaml.deprecated "use Proof_global.set_endline_tactic"] + +(** {6 ... } *) +(** [set_used_variables l] declares that section variables [l] will be + used in the proof *) +val set_used_variables : + Id.t list -> Context.Named.t * Names.Id.t Loc.located list +[@@ocaml.deprecated "use Proof_global.set_used_variables"] + +val get_used_variables : unit -> Context.Named.t option +[@@ocaml.deprecated "use Proof_global.get_used_variables"] + +(** {6 Universe binders } *) +val get_universe_binders : unit -> Proof_global.universe_binders option +[@@ocaml.deprecated "use Proof_global.get_universe_binders"] + +(** {6 ... } *) +(** [get_current_proof_name ()] return the name of the current focused + proof or failed if no proof is focused *) +val get_current_proof_name : unit -> Id.t +[@@ocaml.deprecated "use Proof_global.get_current_proof_name"] + +(** [get_all_proof_names ()] returns the list of all pending proof names. + The first name is the current proof, the other names may come in + any order. *) +val get_all_proof_names : unit -> Id.t list +[@@ocaml.deprecated "use Proof_global.get_all_proof_names"] + +type lemma_possible_guards = Proof_global.lemma_possible_guards +[@@ocaml.deprecated "use Proof_global.lemma_possible_guards"] + +type universe_binders = Proof_global.universe_binders +[@@ocaml.deprecated "use Proof_global.universe_binders"] + diff --git a/proofs/proof.ml b/proofs/proof.ml index 2aa620c1da..ef454299ea 100644 --- a/proofs/proof.ml +++ b/proofs/proof.ml @@ -428,7 +428,7 @@ module V82 = struct in let env = Evd.evar_filtered_env evi in let rawc = Constrintern.intern_constr env com in - let ltac_vars = Pretyping.empty_lvar in + let ltac_vars = Glob_ops.empty_lvar in let sigma = Evar_refiner.w_refine (evk, evi) (ltac_vars, rawc) sigma in Proofview.Unsafe.tclEVARS sigma end in diff --git a/proofs/proof_global.ml b/proofs/proof_global.ml index 5ec34a6387..d5fbdbb830 100644 --- a/proofs/proof_global.ml +++ b/proofs/proof_global.ml @@ -336,15 +336,14 @@ let close_proof ~keep_body_ucst_separate ?feedback_id ~now let make_body = if poly || now then let make_body t (c, eff) = - let open Universes in let body = c in let typ = if not (keep_body_ucst_separate || not (Safe_typing.empty_private_constants = eff)) then nf t else t in - let used_univs_body = Universes.universes_of_constr body in - let used_univs_typ = Universes.universes_of_constr typ in + let used_univs_body = Univops.universes_of_constr body in + let used_univs_typ = Univops.universes_of_constr typ in if keep_body_ucst_separate || not (Safe_typing.empty_private_constants = eff) then let initunivs = Evd.evar_context_universe_context initial_euctx in @@ -353,7 +352,7 @@ let close_proof ~keep_body_ucst_separate ?feedback_id ~now * complement the univ constraints of the typ with the ones of * the body. So we keep the two sets distinct. *) let used_univs = Univ.LSet.union used_univs_body used_univs_typ in - let ctx_body = restrict_universe_context ctx used_univs in + let ctx_body = Univops.restrict_universe_context ctx used_univs in (initunivs, typ), ((body, ctx_body), eff) else let initunivs = Univ.UContext.empty in @@ -362,7 +361,7 @@ let close_proof ~keep_body_ucst_separate ?feedback_id ~now * constraints in which we merge the ones for the body and the ones * for the typ *) let used_univs = Univ.LSet.union used_univs_body used_univs_typ in - let ctx = restrict_universe_context ctx used_univs in + let ctx = Univops.restrict_universe_context ctx used_univs in let univs = Univ.ContextSet.to_context ctx in (univs, typ), ((body, Univ.ContextSet.empty), eff) in diff --git a/proofs/refine.ml b/proofs/refine.ml index caa6b9fb30..796b4b8377 100644 --- a/proofs/refine.ml +++ b/proofs/refine.ml @@ -69,7 +69,7 @@ let add_side_effect env = function let add_side_effects env effects = List.fold_left (fun env eff -> add_side_effect env eff) env effects -let generic_refine ?(unsafe = true) f gl = +let generic_refine ~typecheck f gl = let gl = Proofview.Goal.assume gl in let sigma = Proofview.Goal.sigma gl in let env = Proofview.Goal.env gl in @@ -91,9 +91,9 @@ let generic_refine ?(unsafe = true) f gl = let env = add_side_effects env sideff in (** Check that the introduced evars are well-typed *) let fold accu ev = typecheck_evar ev env accu in - let sigma = if unsafe then sigma else CList.fold_left fold sigma evs in + let sigma = if typecheck then CList.fold_left fold sigma evs else sigma in (** Check that the refined term is typesafe *) - let sigma = if unsafe then sigma else typecheck_proof c concl env sigma in + let sigma = if typecheck then typecheck_proof c concl env sigma else sigma in (** Check that the goal itself does not appear in the refined term *) let self = Proofview.Goal.goal gl in let _ = @@ -132,16 +132,16 @@ let lift c = Proofview.tclUNIT c end -let make_refine_enter ?unsafe f gl = generic_refine ?unsafe (lift f) gl +let make_refine_enter ~typecheck f gl = generic_refine ~typecheck (lift f) gl -let refine_one ?(unsafe = true) f = - Proofview.Goal.enter_one (make_refine_enter ~unsafe f) +let refine_one ~typecheck f = + Proofview.Goal.enter_one (make_refine_enter ~typecheck f) -let refine ?(unsafe = true) f = +let refine ~typecheck f = let f evd = let (evd,c) = f evd in (evd,((), c)) in - Proofview.Goal.enter (make_refine_enter ~unsafe f) + Proofview.Goal.enter (make_refine_enter ~typecheck f) (** Useful definitions *) @@ -153,7 +153,7 @@ let with_type env evd c t = in evd , j'.Environ.uj_val -let refine_casted ?unsafe f = Proofview.Goal.enter begin fun gl -> +let refine_casted ~typecheck f = Proofview.Goal.enter begin fun gl -> let gl = Proofview.Goal.assume gl in let concl = Proofview.Goal.concl gl in let env = Proofview.Goal.env gl in @@ -161,7 +161,7 @@ let refine_casted ?unsafe f = Proofview.Goal.enter begin fun gl -> let (h, c) = f h in with_type env h c concl in - refine ?unsafe f + refine ~typecheck f end (** {7 solve_constraints} diff --git a/proofs/refine.mli b/proofs/refine.mli index f1439f9a13..c1c57ecb8e 100644 --- a/proofs/refine.mli +++ b/proofs/refine.mli @@ -21,19 +21,18 @@ val pr_constr : (** {7 Refinement primitives} *) -val refine : ?unsafe:bool -> (Evd.evar_map -> Evd.evar_map * EConstr.t) -> unit tactic -(** In [refine ?unsafe t], [t] is a term with holes under some +val refine : typecheck:bool -> (Evd.evar_map -> Evd.evar_map * EConstr.t) -> unit tactic +(** In [refine ~typecheck t], [t] is a term with holes under some [evar_map] context. The term [t] is used as a partial solution for the current goal (refine is a goal-dependent tactic), the new holes created by [t] become the new subgoals. Exceptions raised during the interpretation of [t] are caught and result in - tactic failures. If [unsafe] is [false] (default is [true]) [t] is - type-checked beforehand. *) + tactic failures. If [typecheck] is [true] [t] is type-checked beforehand. *) -val refine_one : ?unsafe:bool -> (Evd.evar_map -> Evd.evar_map * ('a * EConstr.t)) -> 'a tactic +val refine_one : typecheck:bool -> (Evd.evar_map -> Evd.evar_map * ('a * EConstr.t)) -> 'a tactic (** A variant of [refine] which assumes exactly one goal under focus *) -val generic_refine : ?unsafe:bool -> ('a * EConstr.t) tactic -> +val generic_refine : typecheck:bool -> ('a * EConstr.t) tactic -> [ `NF ] Proofview.Goal.t -> 'a tactic (** The general version of refine. *) @@ -44,7 +43,7 @@ val with_type : Environ.env -> Evd.evar_map -> (** [with_type env sigma c t] ensures that [c] is of type [t] inserting a coercion if needed. *) -val refine_casted : ?unsafe:bool -> (Evd.evar_map -> Evd.evar_map * EConstr.t) -> unit tactic +val refine_casted : typecheck:bool -> (Evd.evar_map -> Evd.evar_map * EConstr.t) -> unit tactic (** Like {!refine} except the refined term is coerced to the conclusion of the current goal. *) diff --git a/stm/stm.ml b/stm/stm.ml index a79bf54267..8ca50e2d54 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -931,7 +931,7 @@ let show_script ?proof () = try let prf = try match proof with - | None -> Some (Pfedit.get_current_proof_name ()) + | None -> Some (Proof_global.get_current_proof_name ()) | Some (p,_) -> Some (p.Proof_global.id) with Proof_global.NoCurrentProof -> None in @@ -2046,7 +2046,8 @@ let collect_proof keep cur hd brkind id = | `ASync(_,pua,_,name,_) -> `Sync (name,pua,why) in let check_policy rc = if async_policy () then rc else make_sync `Policy rc in match cur, (VCS.visit id).step, brkind with - | (parent, { expr = VernacExactProof _ }), `Fork _, _ -> + | (parent, { expr = VernacExactProof _ }), `Fork _, _ + | (parent, { expr = VernacTime (_, VernacExactProof _) }), `Fork _, _ -> `Sync (no_name,None,`Immediate) | _, _, { VCS.kind = `Edit _ } -> check_policy (collect (Some cur) [] id) | _ -> diff --git a/stm/vernac_classifier.ml b/stm/vernac_classifier.ml index 471e05e458..87d9e411a7 100644 --- a/stm/vernac_classifier.ml +++ b/stm/vernac_classifier.ml @@ -142,7 +142,7 @@ let rec classify_vernac e = let ids = List.flatten (List.map (fun (_,(l,_)) -> List.map (fun (id, _) -> snd id) l) l) in VtSideff ids, VtLater | VernacDefinition (_,((_,id),_),DefineBody _) -> VtSideff [id], VtLater - | VernacInductive (_,_,l) -> + | VernacInductive (_, _,_,l) -> let ids = List.map (fun (((_,((_,id),_)),_,_,_,cl),_) -> id :: match cl with | Constructors l -> List.map (fun (_,((_,id),_)) -> id) l | RecordDecl (oid,l) -> (match oid with Some (_,x) -> [x] | _ -> []) @ diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml index 4bde427b15..5fbf59b815 100644 --- a/tactics/class_tactics.ml +++ b/tactics/class_tactics.ml @@ -250,7 +250,7 @@ let unify_resolve_refine poly flags gls ((c, t, ctx),n,clenv) = let open Clenv in let env = Proofview.Goal.env gls in let concl = Proofview.Goal.concl gls in - Refine.refine ~unsafe:true begin fun sigma -> + Refine.refine ~typecheck:false begin fun sigma -> let sigma, term, ty = if poly then let (subst, ctx) = Universes.fresh_universe_context_set_instance ctx in @@ -649,8 +649,9 @@ module V85 = struct Goal.V82.hyps gls.Evd.sigma (sig_it gls) let make_autogoal_hints = - let cache = ref (true, Environ.empty_named_context_val, - Hint_db.empty full_transparent_state true) + let cache = Summary.ref ~name:"make_autogoal_hints_cache" + (true, Environ.empty_named_context_val, + Hint_db.empty full_transparent_state true) in fun only_classes ?(st=full_transparent_state) g -> let sign = pf_filtered_hyps g in @@ -979,8 +980,9 @@ module Search = struct search_hints : hint_db; } (** Local hints *) - let autogoal_cache = ref (DirPath.empty, true, Context.Named.empty, - Hint_db.empty full_transparent_state true) + let autogoal_cache = Summary.ref ~name:"autogoal_cache" + (DirPath.empty, true, Context.Named.empty, + Hint_db.empty full_transparent_state true) let make_autogoal_hints only_classes ?(st=full_transparent_state) g = let open Proofview in diff --git a/tactics/elimschemes.ml b/tactics/elimschemes.ml index 466b1350d9..99761437eb 100644 --- a/tactics/elimschemes.ml +++ b/tactics/elimschemes.ml @@ -47,7 +47,7 @@ let optimize_non_type_induction_scheme kind dep sort _ ind = (nf c', Evd.evar_universe_context sigma), eff else let mib,mip = Inductive.lookup_mind_specif env ind in - let ctx = Declareops.inductive_context mib in + let ctx = Declareops.inductive_polymorphic_context mib in let u = Univ.UContext.instance ctx in let ctxset = Univ.ContextSet.of_context ctx in let ectx = Evd.evar_universe_context_of ctxset in @@ -60,7 +60,7 @@ let build_induction_scheme_in_type dep sort ind = let sigma = Evd.from_env env in let ctx = let mib,mip = Inductive.lookup_mind_specif env ind in - Declareops.inductive_context mib + Declareops.inductive_polymorphic_context mib in let u = Univ.UContext.instance ctx in let ctxset = Univ.ContextSet.of_context ctx in @@ -80,30 +80,30 @@ let rect_dep_scheme_kind_from_type = declare_individual_scheme_object "_rect" ~aux:"_rect_from_type" (fun _ x -> build_induction_scheme_in_type true InType x, Safe_typing.empty_private_constants) -let ind_scheme_kind_from_type = - declare_individual_scheme_object "_ind_nodep" - (optimize_non_type_induction_scheme rect_scheme_kind_from_type false InProp) - -let ind_scheme_kind_from_prop = - declare_individual_scheme_object "_ind" ~aux:"_ind_from_prop" - (optimize_non_type_induction_scheme rect_scheme_kind_from_prop false InProp) - -let ind_dep_scheme_kind_from_type = - declare_individual_scheme_object "_ind" ~aux:"_ind_from_type" - (optimize_non_type_induction_scheme rect_dep_scheme_kind_from_type true InProp) +let rec_scheme_kind_from_type = + declare_individual_scheme_object "_rec_nodep" ~aux:"_rec_nodep_from_type" + (optimize_non_type_induction_scheme rect_scheme_kind_from_type false InSet) let rec_scheme_kind_from_prop = declare_individual_scheme_object "_rec" ~aux:"_rec_from_prop" (optimize_non_type_induction_scheme rect_scheme_kind_from_prop false InSet) -let rec_scheme_kind_from_type = - declare_individual_scheme_object "_rec_nodep" ~aux:"_rec_nodep_from_type" - (optimize_non_type_induction_scheme rect_scheme_kind_from_type false InSet) - let rec_dep_scheme_kind_from_type = declare_individual_scheme_object "_rec" ~aux:"_rec_from_type" (optimize_non_type_induction_scheme rect_dep_scheme_kind_from_type true InSet) +let ind_scheme_kind_from_type = + declare_individual_scheme_object "_ind_nodep" + (optimize_non_type_induction_scheme rec_scheme_kind_from_type false InProp) + +let ind_dep_scheme_kind_from_type = + declare_individual_scheme_object "_ind" ~aux:"_ind_from_type" + (optimize_non_type_induction_scheme rec_dep_scheme_kind_from_type true InProp) + +let ind_scheme_kind_from_prop = + declare_individual_scheme_object "_ind" ~aux:"_ind_from_prop" + (optimize_non_type_induction_scheme rec_scheme_kind_from_prop false InProp) + (* Case analysis *) let build_case_analysis_scheme_in_type dep sort ind = diff --git a/tactics/elimschemes.mli b/tactics/elimschemes.mli index 77f927f2df..da432beadc 100644 --- a/tactics/elimschemes.mli +++ b/tactics/elimschemes.mli @@ -10,6 +10,14 @@ open Ind_tables (** Induction/recursion schemes *) +val optimize_non_type_induction_scheme : + 'a Ind_tables.scheme_kind -> + Indrec.dep_flag -> + Term.sorts_family -> + 'b -> + Names.inductive -> + (Constr.constr * Evd.evar_universe_context) * Safe_typing.private_constants + val rect_scheme_kind_from_prop : individual scheme_kind val ind_scheme_kind_from_prop : individual scheme_kind val rec_scheme_kind_from_prop : individual scheme_kind diff --git a/tactics/eqdecide.ml b/tactics/eqdecide.ml index 0cee4b6edb..10bc6e3e24 100644 --- a/tactics/eqdecide.ml +++ b/tactics/eqdecide.ml @@ -72,7 +72,7 @@ let generalize_right mk typ c1 c2 = Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let store = Proofview.Goal.extra gl in - Refine.refine ~unsafe:true begin fun sigma -> + Refine.refine ~typecheck:false begin fun sigma -> let na = Name (next_name_away_with_default "x" Anonymous (Termops.ids_of_context env)) in let newconcl = mkProd (na, typ, mk typ c1 (mkRel 1)) in let (sigma, x) = Evarutil.new_evar env sigma ~principal:true ~store newconcl in diff --git a/tactics/equality.ml b/tactics/equality.ml index 05c5cd5ec1..6e56dc48e5 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -50,13 +50,12 @@ module NamedDecl = Context.Named.Declaration let discriminate_introduction = ref true -let discr_do_intro () = - !discriminate_introduction && Flags.version_strictly_greater Flags.V8_2 +let discr_do_intro () = !discriminate_introduction open Goptions let _ = declare_bool_option - { optdepr = false; + { optdepr = true; (* remove in 8.8 *) optname = "automatic introduction of hypotheses by discriminate"; optkey = ["Discriminate";"Introduction"]; optread = (fun () -> !discriminate_introduction); @@ -64,13 +63,11 @@ let _ = let injection_pattern_l2r_order = ref true -let use_injection_pattern_l2r_order () = - !injection_pattern_l2r_order - && Flags.version_strictly_greater Flags.V8_4 +let use_injection_pattern_l2r_order () = !injection_pattern_l2r_order let _ = declare_bool_option - { optdepr = false; + { optdepr = true; (* remove in 8.8 *) optname = "injection left-to-right pattern order and clear by default when with introduction pattern"; optkey = ["Injection";"L2R";"Pattern";"Order"]; optread = (fun () -> !injection_pattern_l2r_order) ; @@ -356,7 +353,6 @@ let find_elim hdcncl lft2rgt dep cls ot gl = if (is_global Coqlib.glob_eq hdcncl || (is_global Coqlib.glob_jmeq hdcncl && jmeq_same_dom gl ot)) && not dep - || Flags.version_less_or_equal Flags.V8_2 then let c = match EConstr.kind sigma hdcncl with @@ -1418,7 +1414,7 @@ let injEqThen tac l2r (eq,_,(t,t1,t2) as u) eq_clause = "" else " You can try to use option Set Keep Proof Equalities." in tclZEROMSG (strbrk("No information can be deduced from this equality and the injectivity of constructors. This may be because the terms are convertible, or due to pattern matching restrictions in the sort Prop." ^ suggestion)) - | Inr [([],_,_)] when Flags.version_strictly_greater Flags.V8_3 -> + | Inr [([],_,_)] -> tclZEROMSG (str"Nothing to inject.") | Inr posns -> inject_at_positions env sigma l2r u eq_clause posns @@ -1769,13 +1765,10 @@ type subst_tactic_flags = { rewrite_dependent_proof : bool } -let default_subst_tactic_flags () = - if Flags.version_strictly_greater Flags.V8_2 then - { only_leibniz = false; rewrite_dependent_proof = true } - else - { only_leibniz = true; rewrite_dependent_proof = false } +let default_subst_tactic_flags = + { only_leibniz = false; rewrite_dependent_proof = true } -let subst_all ?(flags=default_subst_tactic_flags ()) () = +let subst_all ?(flags=default_subst_tactic_flags) () = if !regular_subst_tactic then diff --git a/tactics/hints.ml b/tactics/hints.ml index 773abb9f0c..2fc8baa895 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -29,7 +29,6 @@ open Decl_kinds open Pattern open Patternops open Clenv -open Pfedit open Tacred open Printer open Vernacexpr @@ -1307,7 +1306,8 @@ let interp_hints poly = List.init (nconstructors ind) (fun i -> let c = (ind,i+1) in let gr = ConstructRef c in - empty_hint_info, mib.Declarations.mind_polymorphic, true, + empty_hint_info, + (Declareops.inductive_is_polymorphic mib), true, PathHints [gr], IsGlobRef gr) in HintsResolveEntry (List.flatten (List.map constr_hints_of_ind lqid)) | HintsExtern (pri, patcom, tacexp) -> @@ -1462,7 +1462,7 @@ let pr_hint_term sigma cl = (* print all hints that apply to the concl of the current goal *) let pr_applicable_hint () = - let pts = get_pftreestate () in + let pts = Proof_global.give_me_the_proof () in let glss = Proof.V82.subgoals pts in match glss.Evd.it with | [] -> CErrors.user_err Pp.(str "No focused goal.") diff --git a/tactics/inv.ml b/tactics/inv.ml index ec038f638e..2bc9d9f788 100644 --- a/tactics/inv.ml +++ b/tactics/inv.ml @@ -460,7 +460,7 @@ let raw_inversion inv_kind id status names = in let refined id = let prf = mkApp (mkVar id, args) in - Refine.refine (fun h -> (h, prf)) + Refine.refine ~typecheck:false (fun h -> (h, prf)) in let neqns = List.length realargs in let as_mode = names != None in diff --git a/tactics/tactics.ml b/tactics/tactics.ml index b553f316c2..689cc48aa2 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -25,7 +25,6 @@ open Inductiveops open Reductionops open Globnames open Evd -open Pfedit open Tacred open Genredexpr open Tacmach.New @@ -64,11 +63,10 @@ let dependent_propositions_elimination = ref true let use_dependent_propositions_elimination () = !dependent_propositions_elimination - && Flags.version_strictly_greater Flags.V8_2 let _ = declare_bool_option - { optdepr = false; + { optdepr = true; (* remove in 8.8 *) optname = "dependent-propositions-elimination tactic"; optkey = ["Dependent";"Propositions";"Elimination"]; optread = (fun () -> !dependent_propositions_elimination) ; @@ -142,11 +140,10 @@ let bracketing_last_or_and_intro_pattern = ref true let use_bracketing_last_or_and_intro_pattern () = !bracketing_last_or_and_intro_pattern - && Flags.version_strictly_greater Flags.V8_4 let _ = declare_bool_option - { optdepr = false; + { optdepr = true; (* remove in 8.8 *) optname = "bracketing last or-and introduction pattern"; optkey = ["Bracketing";"Last";"Introduction";"Pattern"]; optread = (fun () -> !bracketing_last_or_and_intro_pattern); @@ -163,7 +160,7 @@ let _ = (** This tactic creates a partial proof realizing the introduction rule, but does not check anything. *) let unsafe_intro env store decl b = - Refine.refine ~unsafe:true begin fun sigma -> + Refine.refine ~typecheck:false begin fun sigma -> let ctx = named_context_val env in let nctx = push_named_context_val decl ctx in let inst = List.map (NamedDecl.get_id %> mkVar) (named_context env) in @@ -200,7 +197,7 @@ let convert_concl ?(check=true) ty k = let env = Proofview.Goal.env gl in let store = Proofview.Goal.extra gl in let conclty = Proofview.Goal.concl gl in - Refine.refine ~unsafe:true begin fun sigma -> + Refine.refine ~typecheck:false begin fun sigma -> let sigma = if check then begin ignore (Typing.unsafe_type_of env sigma ty); @@ -222,7 +219,7 @@ let convert_hyp ?(check=true) d = let store = Proofview.Goal.extra gl in let sign = convert_hyp check (named_context_val env) sigma d in let env = reset_with_named_context sign env in - Refine.refine ~unsafe:true begin fun sigma -> + Refine.refine ~typecheck:false begin fun sigma -> Evarutil.new_evar env sigma ~principal:true ~store ty end end @@ -293,7 +290,7 @@ let clear_gen fail = function in let env = reset_with_named_context hyps env in Proofview.tclTHEN (Proofview.Unsafe.tclEVARS !evdref) - (Refine.refine ~unsafe:true begin fun sigma -> + (Refine.refine ~typecheck:false begin fun sigma -> Evarutil.new_evar env sigma ~principal:true concl end) end @@ -323,7 +320,7 @@ let move_hyp id dest = let sign = named_context_val env in let sign' = move_hyp_in_named_context sigma id dest sign in let env = reset_with_named_context sign' env in - Refine.refine ~unsafe:true begin fun sigma -> + Refine.refine ~typecheck:false begin fun sigma -> Evarutil.new_evar env sigma ~principal:true ~store ty end end @@ -377,7 +374,7 @@ let rename_hyp repl = let nconcl = subst concl in let nctx = val_of_named_context nhyps in let instance = List.map (NamedDecl.get_id %> mkVar) hyps in - Refine.refine ~unsafe:true begin fun sigma -> + Refine.refine ~typecheck:false begin fun sigma -> Evarutil.new_evar_instance nctx sigma nconcl ~principal:true ~store instance end end @@ -527,7 +524,7 @@ let mutual_fix f n rest j = Proofview.Goal.enter begin fun gl -> mk_sign (push_named_context_val (LocalAssum (f, ar)) sign) oth in let nenv = reset_with_named_context (mk_sign (named_context_val env) all) env in - Refine.refine begin fun sigma -> + Refine.refine ~typecheck:false begin fun sigma -> let (sigma, evs) = mk_holes nenv sigma (List.map pi3 all) in let ids = List.map pi1 all in let evs = List.map (Vars.subst_vars (List.rev ids)) evs in @@ -543,7 +540,7 @@ end let fix ido n = match ido with | None -> Proofview.Goal.enter begin fun gl -> - let name = Pfedit.get_current_proof_name () in + let name = Proof_global.get_current_proof_name () in let id = new_fresh_id [] name gl in mutual_fix id n [] 0 end @@ -579,7 +576,7 @@ let mutual_cofix f others j = Proofview.Goal.enter begin fun gl -> mk_sign (push_named_context_val (LocalAssum (f, ar)) sign) oth in let nenv = reset_with_named_context (mk_sign (named_context_val env) all) env in - Refine.refine begin fun sigma -> + Refine.refine ~typecheck:false begin fun sigma -> let (ids, types) = List.split all in let (sigma, evs) = mk_holes nenv sigma types in let evs = List.map (Vars.subst_vars (List.rev ids)) evs in @@ -594,7 +591,7 @@ end let cofix ido = match ido with | None -> Proofview.Goal.enter begin fun gl -> - let name = Pfedit.get_current_proof_name () in + let name = Proof_global.get_current_proof_name () in let id = new_fresh_id [] name gl in mutual_cofix id [] 0 end @@ -1140,7 +1137,7 @@ let rec intros_move = function let tactic_infer_flags with_evar = { Pretyping.use_typeclasses = true; Pretyping.solve_unification_constraints = true; - Pretyping.use_hook = solve_by_implicit_tactic (); + Pretyping.use_hook = Pfedit.solve_by_implicit_tactic (); Pretyping.fail_evar = not with_evar; Pretyping.expand_evars = true } @@ -1225,7 +1222,7 @@ let cut c = let id = next_name_away_with_default "H" Anonymous (Tacmach.New.pf_ids_of_hyps gl) in (** Backward compat: normalize [c]. *) let c = if normalize_cut then local_strong whd_betaiota sigma c else c in - Refine.refine ~unsafe:true begin fun h -> + Refine.refine ~typecheck:false begin fun h -> let (h, f) = Evarutil.new_evar ~principal:true env h (mkArrow c (Vars.lift 1 concl)) in let (h, x) = Evarutil.new_evar env h c in let f = mkLetIn (Name id, x, c, mkApp (Vars.lift 1 f, [|mkRel 1|])) in @@ -1666,7 +1663,7 @@ let solve_remaining_apply_goals = if Typeclasses.is_class_type evd concl then let evd', c' = Typeclasses.resolve_one_typeclass env evd concl in Proofview.tclTHEN (Proofview.Unsafe.tclEVARS evd') - (Refine.refine ~unsafe:true (fun h -> (h,c'))) + (Refine.refine ~typecheck:false (fun h -> (h,c'))) else Proofview.tclUNIT () with Not_found -> Proofview.tclUNIT () else Proofview.tclUNIT () @@ -1914,7 +1911,7 @@ let cut_and_apply c = | Prod (_,c1,c2) when Vars.noccurn sigma 1 c2 -> let concl = Proofview.Goal.concl gl in let env = Tacmach.New.pf_env gl in - Refine.refine begin fun sigma -> + Refine.refine ~typecheck:false begin fun sigma -> let typ = mkProd (Anonymous, c2, concl) in let (sigma, f) = Evarutil.new_evar env sigma typ in let (sigma, x) = Evarutil.new_evar env sigma c1 in @@ -1934,7 +1931,7 @@ let cut_and_apply c = (* let refine_no_check = Profile.profile2 refine_no_checkkey refine_no_check *) let exact_no_check c = - Refine.refine ~unsafe:true (fun h -> (h,c)) + Refine.refine ~typecheck:false (fun h -> (h,c)) let exact_check c = Proofview.Goal.enter begin fun gl -> @@ -1959,7 +1956,7 @@ let native_cast_no_check c = cast_no_check Term.NATIVEcast c let exact_proof c = let open Tacmach.New in Proofview.Goal.enter begin fun gl -> - Refine.refine begin fun sigma -> + Refine.refine ~typecheck:false begin fun sigma -> let (c, ctx) = Constrintern.interp_casted_constr (pf_env gl) sigma c (pf_concl gl) in let c = EConstr.of_constr c in let sigma = Evd.merge_universe_context sigma ctx in @@ -2076,7 +2073,7 @@ let clear_body ids = Tacticals.New.tclZEROMSG msg in check <*> - Refine.refine ~unsafe:true begin fun sigma -> + Refine.refine ~typecheck:false begin fun sigma -> Evarutil.new_evar env sigma ~principal:true concl end end @@ -2128,7 +2125,7 @@ let apply_type newcl args = Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let store = Proofview.Goal.extra gl in - Refine.refine begin fun sigma -> + Refine.refine ~typecheck:false begin fun sigma -> let newcl = nf_betaiota sigma newcl (* As in former Logic.refine *) in let (sigma, ev) = Evarutil.new_evar env sigma ~principal:true ~store newcl in @@ -2149,7 +2146,7 @@ let bring_hyps hyps = let concl = Tacmach.New.pf_concl gl in let newcl = List.fold_right mkNamedProd_or_LetIn hyps concl in let args = Array.of_list (Context.Named.to_instance mkVar hyps) in - Refine.refine begin fun sigma -> + Refine.refine ~typecheck:false begin fun sigma -> let (sigma, ev) = Evarutil.new_evar env sigma ~principal:true ~store newcl in (sigma, mkApp (ev, args)) @@ -2888,7 +2885,7 @@ let new_generalize_gen_let lconstr = 0 lconstr (concl, sigma, []) in Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) - (Refine.refine begin fun sigma -> + (Refine.refine ~typecheck:false begin fun sigma -> let (sigma, ev) = Evarutil.new_evar env sigma ~principal:true newcl in (sigma, applist (ev, args)) end) @@ -3598,7 +3595,7 @@ let mk_term_eq homogeneous env sigma ty t ty' t' = let make_abstract_generalize env id typ concl dep ctx body c eqs args refls = let open Context.Rel.Declaration in - Refine.refine begin fun sigma -> + Refine.refine ~typecheck:false begin fun sigma -> let eqslen = List.length eqs in (* Abstract by the "generalized" hypothesis equality proof if necessary. *) let sigma, abshypeq, abshypt = @@ -4418,7 +4415,7 @@ let pose_induction_arg_then isrec with_evars (is_arg_pure_hyp,from_prefix) elim (* and destruct has side conditions first *) Tacticals.New.tclTHENLAST) (Tacticals.New.tclTHENLIST [ - Refine.refine ~unsafe:true begin fun sigma -> + Refine.refine ~typecheck:false begin fun sigma -> let b = not with_evars && with_eq != None in let (sigma, c) = use_bindings env sigma elim b (c0,lbind) t0 in let t = Retyping.get_type_of env sigma c in @@ -4441,7 +4438,7 @@ let pose_induction_arg_then isrec with_evars (is_arg_pure_hyp,from_prefix) elim let env = reset_with_named_context sign env in let tac = Tacticals.New.tclTHENLIST [ - Refine.refine ~unsafe:true begin fun sigma -> + Refine.refine ~typecheck:false begin fun sigma -> mkletin_goal env sigma store with_eq true (id,lastlhyp,ccl,c) None end; tac @@ -5032,11 +5029,11 @@ let name_op_to_name name_op object_kind suffix = let default_gk = (Global, false, object_kind) in match name_op with | Some s -> - (try let _, gk, _ = current_proof_statement () in s, gk + (try let _, gk, _ = Pfedit.current_proof_statement () in s, gk with NoCurrentProof -> s, default_gk) | None -> let name, gk = - try let name, gk, _ = current_proof_statement () in name, gk + try let name, gk, _ = Pfedit.current_proof_statement () in name, gk with NoCurrentProof -> anon_id, default_gk in add_suffix name suffix, gk @@ -5101,7 +5098,7 @@ module New = struct rZeta=false;rDelta=false;rConst=[]}) {onhyps; concl_occs=AllOccurrences } - let refine ?unsafe c = - Refine.refine ?unsafe c <*> + let refine ~typecheck c = + Refine.refine ~typecheck c <*> reduce_after_refine end diff --git a/tactics/tactics.mli b/tactics/tactics.mli index ec8fe11456..2e17b8dd5c 100644 --- a/tactics/tactics.mli +++ b/tactics/tactics.mli @@ -435,8 +435,8 @@ end module New : sig - val refine : ?unsafe:bool -> (evar_map -> evar_map * constr) -> unit Proofview.tactic - (** [refine ?unsafe c] is [Refine.refine ?unsafe c] + val refine : typecheck:bool -> (evar_map -> evar_map * constr) -> unit Proofview.tactic + (** [refine ~typecheck c] is [Refine.refine ~typecheck c] followed by beta-iota-reduction of the conclusion. *) val reduce_after_refine : unit Proofview.tactic diff --git a/test-suite/bugs/closed/2141.v b/test-suite/bugs/closed/2141.v index 941ae530fd..098a7e9e72 100644 --- a/test-suite/bugs/closed/2141.v +++ b/test-suite/bugs/closed/2141.v @@ -1,3 +1,4 @@ +Require Coq.extraction.Extraction. Require Import FSetList. Require Import OrderedTypeEx. diff --git a/test-suite/bugs/closed/3036.v b/test-suite/bugs/closed/3036.v index 451bec9b20..3b57310d6e 100644 --- a/test-suite/bugs/closed/3036.v +++ b/test-suite/bugs/closed/3036.v @@ -15,11 +15,11 @@ Definition perm := Qc. Locate Qle_bool. Definition compatibleb (p1 p2 : perm) : bool := -let p1pos := Qle_bool 00 p1 in - let p2pos := Qle_bool 00 p2 in +let p1pos := Qle_bool 0 p1 in + let p2pos := Qle_bool 0 p2 in negb ( (p1pos && p2pos) - || ((p1pos || p2pos) && (negb (Qle_bool 00 ((p1 + p2)%Qc)))))%Qc. + || ((p1pos || p2pos) && (negb (Qle_bool 0 ((p1 + p2)%Qc)))))%Qc. Definition compatible (p1 p2 : perm) := compatibleb p1 p2 = true. diff --git a/test-suite/bugs/closed/3287.v b/test-suite/bugs/closed/3287.v index 7c78131252..1b758acd73 100644 --- a/test-suite/bugs/closed/3287.v +++ b/test-suite/bugs/closed/3287.v @@ -1,3 +1,5 @@ +Require Coq.extraction.Extraction. + Module Foo. (* Definition foo := (I,I). *) Definition bar := true. diff --git a/test-suite/bugs/closed/3330.v b/test-suite/bugs/closed/3330.v index e3b5e94356..672fb3f131 100644 --- a/test-suite/bugs/closed/3330.v +++ b/test-suite/bugs/closed/3330.v @@ -41,6 +41,8 @@ Notation "g 'o' f" := (compose g f) (at level 40, left associativity) : function Open Scope function_scope. +Set Printing Universes. Set Printing All. + Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a. @@ -156,7 +158,8 @@ Delimit Scope morphism_scope with morphism. Delimit Scope category_scope with category. Delimit Scope object_scope with object. - +Set Printing Universes. +Set Printing All. Record PreCategory := Build_PreCategory' { object :> Type; @@ -1069,7 +1072,7 @@ Section Adjunction. Variable F : Functor C D. Variable G : Functor D C. - Let Adjunction_Type := + Let Adjunction_Type := Eval simpl in (hom_functor D) o (F^op, 1) <~=~> (hom_functor C) o (1, G). Record AdjunctionHom := diff --git a/test-suite/bugs/closed/3923.v b/test-suite/bugs/closed/3923.v index 0aa029e73d..2fb0a5439a 100644 --- a/test-suite/bugs/closed/3923.v +++ b/test-suite/bugs/closed/3923.v @@ -1,3 +1,5 @@ +Require Coq.extraction.Extraction. + Module Type TRIVIAL. Parameter t:Type. End TRIVIAL. diff --git a/test-suite/bugs/closed/4366.v b/test-suite/bugs/closed/4366.v index 6a5e9a4023..403c2d2026 100644 --- a/test-suite/bugs/closed/4366.v +++ b/test-suite/bugs/closed/4366.v @@ -10,6 +10,6 @@ end. Goal True. Proof. pose (v := stupid 24). -Timeout 2 vm_compute in v. +Timeout 4 vm_compute in v. exact I. Qed. diff --git a/test-suite/bugs/closed/4394.v b/test-suite/bugs/closed/4394.v deleted file mode 100644 index 1ad81345db..0000000000 --- a/test-suite/bugs/closed/4394.v +++ /dev/null @@ -1,19 +0,0 @@ -(* -*- coq-prog-args: ("-compat" "8.4") -*- *) - -Require Import Equality List. -Inductive Foo (I : Type -> Type) (A : Type) : Type := -| foo (B : Type) : A -> I B -> Foo I A. -Definition Family := Type -> Type. -Definition FooToo : Family -> Family := Foo. -Definition optionize (I : Type -> Type) (A : Type) := option (I A). -Definition bar (I : Type -> Type) (A : Type) : A -> option (I A) -> Foo (optionize I) A := foo (optionize I) A A. -Record Rec (I : Type -> Type) := { rec : forall A : Type, A -> I A -> Foo I A }. -Definition barRec : Rec (optionize id) := {| rec := bar id |}. -Inductive Empty {T} : T -> Prop := . -Theorem empty (family : Family) (a : fold_right prod unit (map (Foo family) nil)) (b : unit) : - Empty (a, b) -> False. -Proof. - intro e. - dependent induction e. -Qed. - diff --git a/test-suite/bugs/closed/4400.v b/test-suite/bugs/closed/4400.v deleted file mode 100644 index a89cf0cbc3..0000000000 --- a/test-suite/bugs/closed/4400.v +++ /dev/null @@ -1,19 +0,0 @@ -(* -*- coq-prog-args: ("-require" "Coq.Compat.Coq84" "-compat" "8.4") -*- *) -Require Import Coq.Lists.List Coq.Logic.JMeq Program.Equality. -Set Printing Universes. -Inductive Foo (I : Type -> Type) (A : Type) : Type := -| foo (B : Type) : A -> I B -> Foo I A. -Definition Family := Type -> Type. -Definition FooToo : Family -> Family := Foo. -Definition optionize (I : Type -> Type) (A : Type) := option (I A). -Definition bar (I : Type -> Type) (A : Type) : A -> option (I A) -> Foo(optionize I) A := foo (optionize I) A A. -Record Rec (I : Type -> Type) := { rec : forall A : Type, A -> I A -> Foo I A }. -Definition barRec : Rec (optionize id) := {| rec := bar id |}. -Inductive Empty {T} : T -> Prop := . -Theorem empty (family : Family) (a : fold_right prod unit (map (Foo family) -nil)) (b : unit) : - Empty (a, b) -> False. -Proof. - intro e. - dependent induction e. -Qed. diff --git a/test-suite/bugs/closed/4616.v b/test-suite/bugs/closed/4616.v index c862f82067..a59975dbcf 100644 --- a/test-suite/bugs/closed/4616.v +++ b/test-suite/bugs/closed/4616.v @@ -1,3 +1,5 @@ +Require Coq.extraction.Extraction. + Set Primitive Projections. Record Foo' := Foo { foo : Type }. Axiom f : forall t : Foo', foo t. diff --git a/test-suite/bugs/closed/4656.v b/test-suite/bugs/closed/4656.v deleted file mode 100644 index a59eed2c86..0000000000 --- a/test-suite/bugs/closed/4656.v +++ /dev/null @@ -1,4 +0,0 @@ -(* -*- coq-prog-args: ("-compat" "8.4") -*- *) -Goal True. - constructor 1. -Qed. diff --git a/test-suite/bugs/closed/4710.v b/test-suite/bugs/closed/4710.v index fdc8501099..5d8ca330ac 100644 --- a/test-suite/bugs/closed/4710.v +++ b/test-suite/bugs/closed/4710.v @@ -1,3 +1,5 @@ +Require Coq.extraction.Extraction. + Set Primitive Projections. Record Foo' := Foo { foo : nat }. Extraction foo. diff --git a/test-suite/bugs/closed/4727.v b/test-suite/bugs/closed/4727.v deleted file mode 100644 index cfb4548d2c..0000000000 --- a/test-suite/bugs/closed/4727.v +++ /dev/null @@ -1,10 +0,0 @@ -(* -*- coq-prog-args: ("-compat" "8.4") -*- *) -Goal forall (P : Set) (l : P) (P0 : Set) (w w0 : P0) (T : Type) (a : P * T) (o : P -> option P0), - (forall (l1 l2 : P) (w1 : P0), o l1 = Some w1 -> o l2 = Some w1 -> l1 = l2) -> - o l = Some w -> o (fst a) = Some w0 -> {w = w0} + {w <> w0} -> False. -Proof. - clear; intros ???????? inj H0 H1 H2. - destruct H2; intuition subst. - eapply inj in H1; [ | eauto ]. - progress subst. (* should succeed, used to not succeed *) -Abort. diff --git a/test-suite/bugs/closed/4733.v b/test-suite/bugs/closed/4733.v deleted file mode 100644 index a90abd71cf..0000000000 --- a/test-suite/bugs/closed/4733.v +++ /dev/null @@ -1,52 +0,0 @@ -(* -*- coq-prog-args: ("-compat" "8.4") -*- *) -(*Suppose a user wants to declare a new list-like notation with support for singletons in both 8.4 and 8.5. If they use*) -Require Import Coq.Lists.List. -Require Import Coq.Vectors.Vector. -Import ListNotations. -Import VectorNotations. -Set Implicit Arguments. -Inductive mylist T := mynil | mycons (_ : T) (_ : mylist T). -Arguments mynil {_}, _. - -Delimit Scope mylist_scope with mylist. -Bind Scope mylist_scope with mylist. -Delimit Scope vector_scope with vector. - -Notation " [ ] " := mynil (format "[ ]") : mylist_scope. -Notation " [ x ] " := (mycons x mynil) : mylist_scope. -Notation " [ x ; .. ; y ] " := (mycons x .. (mycons y mynil) ..) : mylist_scope. - -(** All of these should work fine in -compat 8.4 mode, just as they do in Coq 8.4. There needs to be a way to specify notations above so that all of these [Check]s go through in both 8.4 and 8.5 *) -Check [ ]%mylist : mylist _. -Check [ ]%list : list _. -Check []%vector : Vector.t _ _. -Check [ _ ]%mylist : mylist _. -Check [ _ ]%list : list _. -Check [ _ ]%vector : Vector.t _ _. -Check [ _ ; _ ]%list : list _. -Check [ _ ; _ ]%vector : Vector.t _ _. -Check [ _ ; _ ]%mylist : mylist _. -Check [ _ ; _ ; _ ]%list : list _. -Check [ _ ; _ ; _ ]%vector : Vector.t _ _. -Check [ _ ; _ ; _ ]%mylist : mylist _. -Check [ _ ; _ ; _ ; _ ]%list : list _. -Check [ _ ; _ ; _ ; _ ]%vector : Vector.t _ _. -Check [ _ ; _ ; _ ; _ ]%mylist : mylist _. - -Notation " [ x ; y ; .. ; z ] " := (mycons x (mycons y .. (mycons z mynil) ..)) : mylist_scope. -(* Now these all work, but not so in 8.4. If we get the ability to remove notations, this section can also just be removed. *) -Check [ ]%mylist : mylist _. -Check [ ]%list : list _. -Check []%vector : Vector.t _ _. -Check [ _ ]%mylist : mylist _. -Check [ _ ]%list : list _. -Check [ _ ]%vector : Vector.t _ _. -Check [ _ ; _ ]%list : list _. -Check [ _ ; _ ]%vector : Vector.t _ _. -Check [ _ ; _ ]%mylist : mylist _. -Check [ _ ; _ ; _ ]%list : list _. -Check [ _ ; _ ; _ ]%vector : Vector.t _ _. -Check [ _ ; _ ; _ ]%mylist : mylist _. -Check [ _ ; _ ; _ ; _ ]%list : list _. -Check [ _ ; _ ; _ ; _ ]%vector : Vector.t _ _. -Check [ _ ; _ ; _ ; _ ]%mylist : mylist _. diff --git a/test-suite/bugs/closed/5372.v b/test-suite/bugs/closed/5372.v index 2dc78d4c7f..e60244cd1d 100644 --- a/test-suite/bugs/closed/5372.v +++ b/test-suite/bugs/closed/5372.v @@ -1,4 +1,5 @@ (* coq bug 5372: https://coq.inria.fr/bugs/show_bug.cgi?id=5372 *) +Require Import FunInd. Function odd (n:nat) := match n with | 0 => false diff --git a/test-suite/bugs/closed/5414.v b/test-suite/bugs/closed/5414.v new file mode 100644 index 0000000000..2522a274fb --- /dev/null +++ b/test-suite/bugs/closed/5414.v @@ -0,0 +1,12 @@ +(* Use of idents bound to ltac names in a "match" *) + +Definition foo : Type. +Proof. + let x := fresh "a" in + refine (forall k : nat * nat, let '(x, _) := k in (_ : Type)). + exact (a = a). +Defined. +Goal foo. +intros k. elim k. (* elim because elim keeps names *) +intros. +Check a. (* We check that the name is "a" *) diff --git a/test-suite/bugs/closed/5578.v b/test-suite/bugs/closed/5578.v new file mode 100644 index 0000000000..5bcdaa2f18 --- /dev/null +++ b/test-suite/bugs/closed/5578.v @@ -0,0 +1,57 @@ +(* File reduced by coq-bug-finder from original input, then from 1549 lines to 298 lines, then from 277 lines to 133 lines, then from 985 lines to 138 lines, then from 206 lines to 139 lines, then from 203 lines to 142 lines, then from 262 lines to 152 lines, then from 567 lines to 151 lines, then from 3746 lines to 151 lines, then from 577 lines to 151 lines, then from 187 lines to 151 lines, thenfrom 981 lines to 940 lines, then from 938 lines to 175 lines, then from 589 lines to 205 lines, then from 3797 lines to 205 lines, then from 628 lines to 206 lines, then from 238 lines to 205 lines, then from 1346 lines to 213 lines, then from 633 lines to 214 lines, then from 243 lines to 213 lines, then from 5656 lines to 245 lines, then from 661 lines to 272 lines, then from 3856 lines to 352 lines, then from 1266 lines to 407 lines, then from 421 lines to 406 lines, then from 424 lines to 91 lines, then from 105 lines to 91 lines, then from 85 lines to 55 lines, then from 69 lines to 55 lines *) +(* coqc version trunk (May 2017) compiled on May 30 2017 13:28:59 with OCaml +4.02.3 + coqtop version jgross-Leopard-WS:/home/jgross/Downloads/coq/coq-trunk,trunk (fd36c0451c26e44b1b7e93299d3367ad2d35fee3) *) + +Class Proper {A} (R : A -> A -> Prop) (m : A) := mkp : R m m. +Definition respectful {A B} (R : A -> A -> Prop) (R' : B -> B -> Prop) (f g : A -> B) := forall x y, R x y -> R' (f x) (g y). +Set Implicit Arguments. + +Class EqDec (A : Set) := { + eqb : A -> A -> bool ; + eqb_leibniz : forall x y, eqb x y = true <-> x = y +}. + +Infix "?=" := eqb (at level 70) : eq_scope. + +Inductive Comp : Set -> Type := +| Bind : forall (A B : Set), Comp B -> (B -> Comp A) -> Comp A. + +Open Scope eq_scope. + +Goal forall (Rat : Set) (PositiveMap_t : Set -> Set) + type (t : type) (interp_type_list_message interp_type_rand interp_type_message : nat -> Set), + (forall eta : nat, PositiveMap_t (interp_type_rand eta) -> interp_type_list_message eta -> interp_type_message eta) -> + ((nat -> Rat) -> Prop) -> + forall (interp_type_sbool : nat -> Set) (interp_type0 : type -> nat -> Set), + (forall eta : nat, + (interp_type_list_message eta -> interp_type_message eta) -> PositiveMap_t (interp_type_rand eta) -> interp_type0 t eta) + -> (forall (t0 : type) (eta : nat), EqDec (interp_type0 t0 eta)) + -> (bool -> Comp bool) -> False. + clear. + intros Rat PositiveMap_t type t interp_type_list_message interp_type_rand interp_type_message adv negligible interp_type_sbool + interp_type interp_term_fixed_t_x + EqDec_interp_type ret_bool. + assert (forall f adv' k + (lem : forall (eta : nat) (evil_rands rands : PositiveMap_t +(interp_type_rand eta)), + (interp_term_fixed_t_x eta (adv eta evil_rands) rands + ?= interp_term_fixed_t_x eta (adv eta evil_rands) rands) = true), + (forall (eta : nat), Proper (respectful eq eq) (f eta)) + -> negligible + (fun eta : nat => + f eta ( + (Bind (k eta) (fun rands => + ret_bool (interp_term_fixed_t_x eta (adv' eta) rands ?= interp_term_fixed_t_x eta (adv' eta) rands)))))). + Undo. + assert (forall f adv' k + (lem : forall (eta : nat) (rands : PositiveMap_t +(interp_type_rand eta)), + (interp_term_fixed_t_x eta (adv' eta) rands ?= interp_term_fixed_t_x eta (adv' eta) rands) = true), + (forall (eta : nat), Proper (respectful eq eq) (f eta)) + -> negligible + (fun eta : nat => + f eta ( + (Bind (k eta) (fun rands => + ret_bool (interp_term_fixed_t_x eta (adv' eta) rands ?= interp_term_fixed_t_x eta (adv' eta) rands)))))). + (* Error: Anomaly "Signature and its instance do not match." Please report at http://coq.inria.fr/bugs/. *)
\ No newline at end of file diff --git a/test-suite/bugs/opened/4803.v b/test-suite/bugs/opened/4803.v deleted file mode 100644 index 4541f13d01..0000000000 --- a/test-suite/bugs/opened/4803.v +++ /dev/null @@ -1,48 +0,0 @@ -(* -*- coq-prog-args: ("-compat" "8.4") -*- *) -(*Suppose a user wants to declare a new list-like notation with support for singletons in both 8.4 and 8.5. If they use*) -Require Import Coq.Lists.List. -Require Import Coq.Vectors.Vector. -Import ListNotations. -Import VectorNotations. -Set Implicit Arguments. -Inductive mylist T := mynil | mycons (_ : T) (_ : mylist T). -Arguments mynil {_}, _. - -Delimit Scope mylist_scope with mylist. -Bind Scope mylist_scope with mylist. -Delimit Scope vector_scope with vector. - -Notation " [ ] " := mynil (format "[ ]") : mylist_scope. -Notation " [ x ] " := (mycons x mynil) : mylist_scope. -Notation " [ x ; .. ; y ] " := (mycons x .. (mycons y mynil) ..) : mylist_scope. - -(** All of these should work fine in -compat 8.4 mode, just as they do in Coq 8.4. There needs to be a way to specify notations above so that all of these [Check]s go through in both 8.4 and 8.5 *) -Check [ ]%mylist : mylist _. -Check [ ]%list : list _. -Check []%vector : Vector.t _ _. -Check [ _ ]%mylist : mylist _. -Check [ _ ]%list : list _. -Check [ _ ]%vector : Vector.t _ _. -Check [ _ ; _ ]%list : list _. -Check [ _ ; _ ]%vector : Vector.t _ _. -Check [ _ ; _ ]%mylist : mylist _. -Check [ _ ; _ ; _ ]%list : list _. -Check [ _ ; _ ; _ ]%vector : Vector.t _ _. -Check [ _ ; _ ; _ ]%mylist : mylist _. -Check [ _ ; _ ; _ ; _ ]%list : list _. -Check [ _ ; _ ; _ ; _ ]%vector : Vector.t _ _. -Check [ _ ; _ ; _ ; _ ]%mylist : mylist _. - -(** Now check that we can add and then remove notations from the parser *) -(* We should be able to stick some vernacular here to remove [] from the parser *) -Fail Remove Notation "[]". -Goal True. - (* This should not be a syntax error; before moving this file to closed, uncomment this line. *) - (* idtac; []. *) - constructor. -Qed. - -Check { _ : _ & _ }. -Reserved Infix "&" (at level 0). -Fail Remove Infix "&". -(* Check { _ : _ & _ }. *) diff --git a/test-suite/coq-makefile/arg/_CoqProject b/test-suite/coq-makefile/arg/_CoqProject index afdb32e7cf..53dc963997 100644 --- a/test-suite/coq-makefile/arg/_CoqProject +++ b/test-suite/coq-makefile/arg/_CoqProject @@ -1,7 +1,7 @@ -R theories test -R src test -I src --arg "-compat 8.4" +-arg "-w default" src/test_plugin.mlpack src/test.ml4 diff --git a/test-suite/coqchk/cumulativity.v b/test-suite/coqchk/cumulativity.v new file mode 100644 index 0000000000..a978f6b901 --- /dev/null +++ b/test-suite/coqchk/cumulativity.v @@ -0,0 +1,67 @@ +Set Universe Polymorphism. +Set Inductive Cumulativity. +Set Printing Universes. + +Inductive List (A: Type) := nil | cons : A -> List A -> List A. + +Section ListLift. + Universe i j. + + Constraint i < j. + + Definition LiftL {A} : List@{i} A -> List@{j} A := fun x => x. + +End ListLift. + +Lemma LiftL_Lem A (l : List A) : l = LiftL l. +Proof. reflexivity. Qed. + +Section ListLower. + Universe i j. + + Constraint i < j. + + Definition LowerL {A : Type@{i}} : List@{j} A -> List@{i} A := fun x => x. + +End ListLower. + +Lemma LowerL_Lem@{i j} (A : Type@{j}) (l : List@{i} A) : l = LowerL l. +Proof. reflexivity. Qed. +(* +I disable these tests because cqochk can't process them when compiled with + ocaml-4.02.3+32bit and camlp5-4.16 which is the case for Travis! + + I have added this file (including the commented parts below) in + test-suite/success/cumulativity.v which doesn't run coqchk on them. +*) +(* Inductive Tp := tp : Type -> Tp. *) + +(* Section TpLift. *) +(* Universe i j. *) + +(* Constraint i < j. *) + +(* Definition LiftTp : Tp@{i} -> Tp@{j} := fun x => x. *) + +(* End TpLift. *) + +(* Lemma LiftC_Lem (t : Tp) : LiftTp t = t. *) +(* Proof. reflexivity. Qed. *) + +(* Section TpLower. *) +(* Universe i j. *) + +(* Constraint i < j. *) + +(* Fail Definition LowerTp : Tp@{j} -> Tp@{i} := fun x => x. *) + +(* End TpLower. *) + + +(* Section subtyping_test. *) +(* Universe i j. *) +(* Constraint i < j. *) + +(* Inductive TP2 := tp2 : Type@{i} -> Type@{j} -> TP2. *) + +(* End subtyping_test. *)
\ No newline at end of file diff --git a/test-suite/failure/int31.v b/test-suite/failure/int31.v index b1d112247f..ed4c9f9c78 100644 --- a/test-suite/failure/int31.v +++ b/test-suite/failure/int31.v @@ -1,4 +1,4 @@ -Require Import Int31 BigN. +Require Import Int31 Cyclic31. Open Scope int31_scope. diff --git a/test-suite/ide/blocking-futures.fake b/test-suite/ide/blocking-futures.fake index b63f09bcfc..541fb798c0 100644 --- a/test-suite/ide/blocking-futures.fake +++ b/test-suite/ide/blocking-futures.fake @@ -4,6 +4,7 @@ # Extraction will force the future computation, assert it is blocking # Example courtesy of Jonathan (jonikelee) # +ADD { Require Coq.extraction.Extraction. } ADD { Require Import List. } ADD { Import ListNotations. } ADD { Definition myrev{A}(l : list A) : {rl : list A | rl = rev l}. } diff --git a/test-suite/misc/printers.sh b/test-suite/misc/printers.sh index c822d0eb37..28e7dc362f 100755 --- a/test-suite/misc/printers.sh +++ b/test-suite/misc/printers.sh @@ -1,3 +1,3 @@ -printf "Drop. #use\"include\";; #quit;;\n" | $coqtopbyte 2>&1 | grep Unbound +printf "Drop. #use\"include\";; #quit;;\n" | $coqtopbyte 2>&1 | egrep "Error|Unbound" if [ $? = 0 ]; then exit 1; else exit 0; fi diff --git a/test-suite/output/Cases.out b/test-suite/output/Cases.out index f064dfe763..97fa8e2542 100644 --- a/test-suite/output/Cases.out +++ b/test-suite/output/Cases.out @@ -80,3 +80,49 @@ fun '(D n m p q) => n + m + p + q : J -> nat The command has indeed failed with message: The constructor D (in type J) expects 3 arguments. +lem1 = +fun dd : nat * nat => let (bb, cc) as aa return (aa = aa) := dd in eq_refl + : forall k : nat * nat, k = k +lem2 = +fun dd : bool => if dd as aa return (aa = aa) then eq_refl else eq_refl + : forall k : bool, k = k + +Argument scope is [bool_scope] +lem3 = +fun dd : nat * nat => let (bb, cc) as aa return (aa = aa) := dd in eq_refl + : forall k : nat * nat, k = k +1 subgoal + + x : nat + n, n0 := match x + 0 with + | 0 => 0 + | S _ => 0 + end : nat + e, + e0 := match x + 0 as y return (y = y) with + | 0 => eq_refl + | S n => eq_refl + end : x + 0 = x + 0 + n1, n2 := match x with + | 0 => 0 + | S _ => 0 + end : nat + e1, e2 := match x return (x = x) with + | 0 => eq_refl + | S n => eq_refl + end : x = x + ============================ + x + 0 = 0 +1 subgoal + + p : nat + a, + a0 := match eq_refl as y in (_ = e) return (y = y /\ e = e) with + | eq_refl => conj eq_refl eq_refl + end : eq_refl = eq_refl /\ p = p + a1, + a2 := match eq_refl in (_ = e) return (p = p /\ e = e) with + | eq_refl => conj eq_refl eq_refl + end : p = p /\ p = p + ============================ + eq_refl = eq_refl diff --git a/test-suite/output/Cases.v b/test-suite/output/Cases.v index 6a4fd007df..17fee3303d 100644 --- a/test-suite/output/Cases.v +++ b/test-suite/output/Cases.v @@ -121,3 +121,66 @@ Check fun x => let '(D n m p q) := x in n+m+p+q. (* This used to succeed, being interpreted as "let '{{n, m, p}} := ..." *) Fail Check fun x : J => let '{{n, m, _}} p := x in n + m + p. + +(* Test use of idents bound to ltac names in a "match" *) + +Lemma lem1 : forall k, k=k :>nat * nat. +let x := fresh "aa" in +let y := fresh "bb" in +let z := fresh "cc" in +let k := fresh "dd" in +refine (fun k : nat * nat => match k as x return x = x with (y,z) => eq_refl end). +Qed. +Print lem1. + +Lemma lem2 : forall k, k=k :> bool. +let x := fresh "aa" in +let y := fresh "bb" in +let z := fresh "cc" in +let k := fresh "dd" in +refine (fun k => if k as x return x = x then eq_refl else eq_refl). +Qed. +Print lem2. + +Lemma lem3 : forall k, k=k :>nat * nat. +let x := fresh "aa" in +let y := fresh "bb" in +let z := fresh "cc" in +let k := fresh "dd" in +refine (fun k : nat * nat => let (y,z) as x return x = x := k in eq_refl). +Qed. +Print lem3. + +Lemma lem4 x : x+0=0. +match goal with |- ?y = _ => pose (match y with 0 => 0 | S n => 0 end) end. +match goal with |- ?y = _ => pose (match y as y with 0 => 0 | S n => 0 end) end. +match goal with |- ?y = _ => pose (match y as y return y=y with 0 => eq_refl | S n => eq_refl end) end. +match goal with |- ?y = _ => pose (match y return y=y with 0 => eq_refl | S n => eq_refl end) end. +match goal with |- ?y + _ = _ => pose (match y with 0 => 0 | S n => 0 end) end. +match goal with |- ?y + _ = _ => pose (match y as y with 0 => 0 | S n => 0 end) end. +match goal with |- ?y + _ = _ => pose (match y as y return y=y with 0 => eq_refl | S n => eq_refl end) end. +match goal with |- ?y + _ = _ => pose (match y return y=y with 0 => eq_refl | S n => eq_refl end) end. +Show. + +Lemma lem5 (p:nat) : eq_refl p = eq_refl p. +let y := fresh "n" in (* Checking that y is hidden *) + let z := fresh "e" in (* Checking that z is hidden *) + match goal with + |- ?y = _ => pose (match y as y in _ = z return y=y /\ z=z with eq_refl => conj eq_refl eq_refl end) + end. +let y := fresh "n" in + let z := fresh "e" in + match goal with + |- ?y = _ => pose (match y in _ = z return y=y /\ z=z with eq_refl => conj eq_refl eq_refl end) + end. +let y := fresh "n" in + let z := fresh "e" in + match goal with + |- eq_refl ?y = _ => pose (match eq_refl y in _ = z return y=y /\ z=z with eq_refl => conj eq_refl eq_refl end) + end. +let p := fresh "p" in + let z := fresh "e" in + match goal with + |- eq_refl ?p = _ => pose (match eq_refl p in _ = z return p=p /\ z=z with eq_refl => conj eq_refl eq_refl end) + end. +Show. diff --git a/test-suite/output/Extraction_matchs_2413.v b/test-suite/output/Extraction_matchs_2413.v index 6c514b16ee..1ecd9771eb 100644 --- a/test-suite/output/Extraction_matchs_2413.v +++ b/test-suite/output/Extraction_matchs_2413.v @@ -1,5 +1,7 @@ (** Extraction : tests of optimizations of pattern matching *) +Require Coq.extraction.Extraction. + (** First, a few basic tests *) Definition test1 b := diff --git a/test-suite/output/Int31Syntax.out b/test-suite/output/Int31Syntax.out new file mode 100644 index 0000000000..4e8796c14b --- /dev/null +++ b/test-suite/output/Int31Syntax.out @@ -0,0 +1,14 @@ +I31 + : digits31 int31 +2 + : int31 +660865024 + : int31 +2 + 2 + : int31 +2 + 2 + : int31 + = 4 + : int31 + = 710436486 + : int31 diff --git a/test-suite/output/Int31Syntax.v b/test-suite/output/Int31Syntax.v new file mode 100644 index 0000000000..83be3b976b --- /dev/null +++ b/test-suite/output/Int31Syntax.v @@ -0,0 +1,13 @@ +Require Import Int31 Cyclic31. + +Open Scope int31_scope. +Check I31. (* Would be nice to have I31 : digits->digits->...->int31 + For the moment, I31 : digits31 int31, which is better + than (fix nfun .....) size int31 *) +Check 2. +Check 1000000000000000000. (* = 660865024, after modulo 2^31 *) +Check (add31 2 2). +Check (2+2). +Eval vm_compute in 2+2. +Eval vm_compute in 65675757 * 565675998. +Close Scope int31_scope. diff --git a/test-suite/output/NumbersSyntax.out b/test-suite/output/NumbersSyntax.out deleted file mode 100644 index b2677b6ad1..0000000000 --- a/test-suite/output/NumbersSyntax.out +++ /dev/null @@ -1,67 +0,0 @@ -I31 - : digits31 int31 -2 - : int31 -660865024 - : int31 -2 + 2 - : int31 -2 + 2 - : int31 - = 4 - : int31 - = 710436486 - : int31 -2 - : BigN.t' -1000000000000000000 - : BigN.t' -2 + 2 - : bigN -2 + 2 - : bigN - = 4 - : bigN - = 37151199385380486 - : bigN - = 1267650600228229401496703205376 - : bigN -2 - : BigZ.t_ --1000000000000000000 - : BigZ.t_ -2 + 2 - : BigZ.t_ -2 + 2 - : BigZ.t_ - = 4 - : BigZ.t_ - = 37151199385380486 - : BigZ.t_ - = 1267650600228229401496703205376 - : BigZ.t_ -2 - : BigQ.t_ --1000000000000000000 - : BigQ.t_ -2 + 2 - : bigQ -2 + 2 - : bigQ - = 4 - : bigQ - = 37151199385380486 - : bigQ -6562 # 456 - : BigQ.t_ - = 3281 # 228 - : bigQ - = -1 # 10000 - : bigQ - = 100 - : bigQ - = 515377520732011331036461129765621272702107522001 - # 1267650600228229401496703205376 - : bigQ - = 1 - : bigQ diff --git a/test-suite/output/NumbersSyntax.v b/test-suite/output/NumbersSyntax.v deleted file mode 100644 index 4fbf56ab1d..0000000000 --- a/test-suite/output/NumbersSyntax.v +++ /dev/null @@ -1,50 +0,0 @@ - -Require Import BigQ. - -Open Scope int31_scope. -Check I31. (* Would be nice to have I31 : digits->digits->...->int31 - For the moment, I31 : digits31 int31, which is better - than (fix nfun .....) size int31 *) -Check 2. -Check 1000000000000000000. (* = 660865024, after modulo 2^31 *) -Check (add31 2 2). -Check (2+2). -Eval vm_compute in 2+2. -Eval vm_compute in 65675757 * 565675998. -Close Scope int31_scope. - -Open Scope bigN_scope. -Check 2. -Check 1000000000000000000. -Check (BigN.add 2 2). -Check (2+2). -Eval vm_compute in 2+2. -Eval vm_compute in 65675757 * 565675998. -Eval vm_compute in 2^100. -Close Scope bigN_scope. - -Open Scope bigZ_scope. -Check 2. -Check -1000000000000000000. -Check (BigZ.add 2 2). -Check (2+2). -Eval vm_compute in 2+2. -Eval vm_compute in 65675757 * 565675998. -Eval vm_compute in (-2)^100. -Close Scope bigZ_scope. - -Open Scope bigQ_scope. -Check 2. -Check -1000000000000000000. -Check (BigQ.add 2 2). -Check (2+2). -Eval vm_compute in 2+2. -Eval vm_compute in 65675757 * 565675998. -(* fractions *) -Check (6562 # 456). (* Nota: # is BigQ.Qq i.e. base fractions *) -Eval vm_compute in (BigQ.red (6562 # 456)). -Eval vm_compute in (1/-10000). -Eval vm_compute in (BigQ.red (1/(1/100))). (* back to integers... *) -Eval vm_compute in ((2/3)^(-100)). -Eval vm_compute in BigQ.red ((2/3)^(-1000) * (2/3)^(1000)). -Close Scope bigQ_scope. diff --git a/test-suite/success/Case19.v b/test-suite/success/Case19.v index e59828defe..ce98879a5f 100644 --- a/test-suite/success/Case19.v +++ b/test-suite/success/Case19.v @@ -17,3 +17,22 @@ Fail exists (fun x => with | eq_refl => eq_refl end). +Abort. + +(* Some tests with ltac matching on building "if" and "let" *) + +Goal forall b c d, (if negb b then c else d) = 0. +intros. +match goal with +|- (if ?b then ?c else ?d) = 0 => transitivity (if b then d else c) +end. +Abort. + +Definition swap {A} {B} '((x,y):A*B) := (y,x). + +Goal forall p, (let '(x,y) := swap p in x + y) = 0. +intros. +match goal with +|- (let '(x,y) := ?p in x + y) = 0 => transitivity (let (x,y) := p in x+y) +end. +Abort. diff --git a/test-suite/success/Compat84.v b/test-suite/success/Compat84.v deleted file mode 100644 index 732a024fc1..0000000000 --- a/test-suite/success/Compat84.v +++ /dev/null @@ -1,19 +0,0 @@ -(* -*- coq-prog-args: ("-compat" "8.4") -*- *) - -Goal True. - solve [ constructor 1 ]. Undo. - solve [ econstructor 1 ]. Undo. - solve [ constructor ]. Undo. - solve [ econstructor ]. Undo. - solve [ constructor (fail) ]. Undo. - solve [ econstructor (fail) ]. Undo. - split. -Qed. - -Goal False \/ True. - solve [ constructor (constructor) ]. Undo. - solve [ econstructor (econstructor) ]. Undo. - solve [ constructor 2; constructor ]. Undo. - solve [ econstructor 2; econstructor ]. Undo. - right; esplit. -Qed. diff --git a/test-suite/success/Funind.v b/test-suite/success/Funind.v index 3bf97c1312..f87f2e2a9d 100644 --- a/test-suite/success/Funind.v +++ b/test-suite/success/Funind.v @@ -1,4 +1,6 @@ +Require Import Coq.funind.FunInd. + Definition iszero (n : nat) : bool := match n with | O => true diff --git a/test-suite/success/InversionSigma.v b/test-suite/success/InversionSigma.v new file mode 100644 index 0000000000..51f33c7ce7 --- /dev/null +++ b/test-suite/success/InversionSigma.v @@ -0,0 +1,40 @@ +Section inversion_sigma. + Local Unset Implicit Arguments. + Context A (B : A -> Prop) (C C' : forall a, B a -> Prop) + (D : forall a b, C a b -> Prop) (E : forall a b c, D a b c -> Prop). + + (* Require that, after destructing sigma types and inverting + equalities, we can subst equalities of variables only, and reduce + down to [eq_refl = eq_refl]. *) + Local Ltac test_inversion_sigma := + intros; + repeat match goal with + | [ H : sig _ |- _ ] => destruct H + | [ H : sigT _ |- _ ] => destruct H + | [ H : sig2 _ _ |- _ ] => destruct H + | [ H : sigT2 _ _ |- _ ] => destruct H + end; simpl in *; + inversion_sigma; + repeat match goal with + | [ H : ?x = ?y |- _ ] => is_var x; is_var y; subst x; simpl in * + end; + match goal with + | [ |- eq_refl = eq_refl ] => reflexivity + end. + + Goal forall (x y : { a : A & { b : { b : B a & C a b } & { d : D a (projT1 b) (projT2 b) & E _ _ _ d } } }) + (p : x = y), p = p. + Proof. test_inversion_sigma. Qed. + + Goal forall (x y : { a : A | { b : { b : B a | C a b } | { d : D a (proj1_sig b) (proj2_sig b) | E _ _ _ d } } }) + (p : x = y), p = p. + Proof. test_inversion_sigma. Qed. + + Goal forall (x y : { a : { a : A & B a } & C _ (projT2 a) & C' _ (projT2 a) }) + (p : x = y), p = p. + Proof. test_inversion_sigma. Qed. + + Goal forall (x y : { a : { a : A & B a } | C _ (projT2 a) & C' _ (projT2 a) }) + (p : x = y), p = p. + Proof. test_inversion_sigma. Qed. +End inversion_sigma. diff --git a/test-suite/success/NumberScopes.v b/test-suite/success/NumberScopes.v index 6d78721075..1558637476 100644 --- a/test-suite/success/NumberScopes.v +++ b/test-suite/success/NumberScopes.v @@ -39,24 +39,3 @@ Definition f_nat (x:nat) := x. Definition f_nat' (x:Nat.t) := x. Check (f_nat 1). Check (f_nat' 1). - -Require Import BigN. -Check (BigN.add 1 2). -Check (BigN.add_comm 1 2). -Check (BigN.min_comm 1 2). -Definition f_bigN (x:bigN) := x. -Check (f_bigN 1). - -Require Import BigZ. -Check (BigZ.add 1 2). -Check (BigZ.add_comm 1 2). -Check (BigZ.min_comm 1 2). -Definition f_bigZ (x:bigZ) := x. -Check (f_bigZ 1). - -Require Import BigQ. -Check (BigQ.add 1 2). -Check (BigQ.add_comm 1 2). -Check (BigQ.min_comm 1 2). -Definition f_bigQ (x:bigQ) := x. -Check (f_bigQ 1).
\ No newline at end of file diff --git a/test-suite/success/RecTutorial.v b/test-suite/success/RecTutorial.v index d8f8042465..8419404925 100644 --- a/test-suite/success/RecTutorial.v +++ b/test-suite/success/RecTutorial.v @@ -147,6 +147,7 @@ Proof. intros; absurd (p < p); eauto with arith. Qed. +Require Coq.extraction.Extraction. Extraction max. diff --git a/test-suite/success/bigQ.v b/test-suite/success/bigQ.v deleted file mode 100644 index 7fd0cf669d..0000000000 --- a/test-suite/success/bigQ.v +++ /dev/null @@ -1,66 +0,0 @@ -Require Import BigQ. -Import List. - -Definition pi_4_approx_low' := -(5066193963420194617885108698600649932059391557720145469382602092416947640628637390992675949693715109726079394291478795603894419483819297806310615866892414925850691415582239745615128821983865262221858109336884967754871321668348027076234335167119885298878199925731495390387858629042311908406056230882123787019283378509712244687397013657159455607193734144010901984756727174636853404278421831024545476850410085042498464474261035780891759930905778986584183710930670670301831474144997069400304290351567959717683444430666444319233768399342338059169002790777424962570605618705584660815518973602995097110557181643034682308210782171804373210646804613922337450953858508244032293753591878060539465788294318856859293281629951093130167801471787011911886414492513677892193100809508943832528344473873460853362957387889412799458784754514139679847887887544849825173792522272708046699681079289358082661375778523609867456540595586031625044964543428047238934233579184772793670436643502740076366994465457847106782560289782615794595755672643440040123002018908935362541166831619056664637901929131328502017686713274283777724453661234225382109584471950444925886358166551424008707439387934109226545596919797083495958300914344992836193126080289565652575543234385558967555959267746932292860747199382633363026440008828134867747920263181610216905129926037611247017868033961426567047355301676870662406173724238530061264149506666345040372864118731705584795947926329181826992456072045382170981478151356381437136818835196834068650217794381425547036331194595892801393225038235274901050364737353586927051766717037643833477566087835266968086513005761986678747515870298138062157791066648217784877968385924845017637219384732843791052551854695220023477365706464590594542001161575677402761543188277502092362285265847964496740584911576627239093631932307473445797386335961743298553548881544486940399236133577915988716682746485564575640818803540680574730591500432326858763829791848612343662539095316357052823005419355719381626599487868023399182174939253393897549026675976384326749445831606130546375395770778462506203752920470130305293966478109733954117063941901686840180727195741528561335809865193566993349413786715403053579411364371500063193205131503024022217701373077790337150298315820556080596579100618643147698304927957576213733526923182742441048553793831725592624850721293495085399785588171300815789795594858916409701139277050529011775828846362873246196866089783324522718656445008090114701320562608474099248873638488023114015981013142490827777895317580810590743940417298263300561876701828404744082864248409230009391001735746615476377303707782123483770118391136826609366946585715225248587168403619476143657107412319421501162805102723455593551478028055839072686207007765300258935153546418515706362733656094770289090398825190320430416955807878686642673124733998295439657633866090085982598765253268688814792672416195730086607425842181518560588819896560847103627615434844684536463752986969865794019299978956052589825441828842338163389851892617560591840546654410705167593310272272965900821031821380595084783691324416454359888103920904935692840264474003367023256964191100139001239923263691779167792867186165635514824889759796850863175082506408142175595463676408992027105356481220754473245821534527625758942093801142305560662681150069082553674495761075895588095760081401141419460482860852822686860785424514171214889677926763812031823537071721974799922995763666175738785000806081164280471363125324839717808977470218218571800106898347366938927189989988149888641129263448064762730769285877330997355234347773807099829665997515649429224335217107760728789764718885665291038706425454675746218345291274054088843647602239258308472486102933167465443294268551209015027897159307743987020521392788721231001835675584104894174434637260464035122611721657641428625505184886116917149318963070896162119215386541876236027342810162765609201440423207771441367926085768438143507025739041041240810056881304230519058117534418374553879198061289605354335880794397478047346975609179199801003098836622253165101961484972165230151495472006888128587168049198312469715081555662345452800468933420359802645393289853553618279788400476187713990872203669487294118461245455333004125835663010526985716431187034663870796866708678078952110615910196519835267441831874676895301527286826106517027821074816850326548617513767142627360001181210946100011774672126943957522004190414960909074050454565964857276407084991922274068961845339154089866785707764290964299529444616711194034827611771558783466230353209661849406004241580029437779784290315347968833708422223285859451369907260780956405036020581705441364379616715041818815829810906212826084485200785283123265202151252852134381195424724503189247411069117189489985791487434549080447866370484866697404176437230771558469231403088139693477706784802801265075586678597768511791952562627345622499328 - # 100788726492580594349650258277496659410917619472657560321971265983799894639441017438166498752997098978003489632843381325240982516059309714013145358125224597827602157516585886911710102182473475545864474089191789296685473601331678556438310133356793199956062857423397512495293688453655805536015029176541424005214818033707522950635262669828538132795615008381824067071229426026518897202246241637377064076189277685257166926338187911595052586669184297526234794666364657344206795357967279911782849686515024121916258300642000317525374433525235296287037535618423661645124459323811792936193272341688261801253469089129439519903538495370298752436267926761998785090092411372633429302950606054074205533246665546979112178855223925266166034953000200646676762301817000435641690517142795144469005596172113586738287118865058604922865654348297975054956781513943444060257230946224520058527667925776273088622386666860662470481606622952298649177217986593047495967209669116410592230626047083795555559776477430548946990993890380787911273437967786556742804566652408275798339221179283430482118140020742719695900657696142739101628984271513292954605191778803974738871043737934546460016184719168074062912083778327025499841998124431899131874519812228674255796948879306477894924710085384116453080236862135706628989104070747737689294987000148388110561753028594988959655591699155508380909698460304884908709246116411180876105681720036833487450945730831039969246996849503525429840196651386469599438064049723005123629385485140945945416764414133189625489032807860400751723995946290581976152580477047961138617997133510128194027510895265424780627975864980749945631413855375897945293107842908479797077570371447220506451229526132919408351287454305932886749170523056147842439813407002950370505941417426433452282518739345666494683448699945734453214481915512562995906034771246088038719298959180199052759295868161570318718927430655393250250811804905393113074074574608255523847592006804881016594060188745212933427473833239777228852952217878690668413947367586040297784502192683200664398064682201012931468052982448022330449955215606614483165425935154496289535573901139223034819824408001205784146243892228030383941863746839845526558421740316887532141893650230936137269356278754487130882868595412163277284772124736531380334814212708066069618080153747333573454834500999083737284449542481264971030785043701582134343596645346132964567391370300568578875509971483039720438955919863275044932311289587494336123538202079503922025306586828117649623642521324286648529829664567232756108169459356549144779085080036654897525078792273443307070502103724611233768453196294899770515940520895908289018412144327894912660060761908970811602375085884115384049610753387776858733798341463052471017393165656926510611173543365663267563198760597092606598728110197523695339144204179424646442294307593146446562536865057987897899655645968129515654148044008249646703504419478535298270862753806142083172190778193001810574370442181909146645889199829207284871551220439225371051511970054965951914399901815408791418836185742573331879114400013259342896515702942707292473805188905427717363630137869116872433627556880809120353079342030725196065815470427569172350436988386579444534375353968759750750178342190349607711313840613843718547859929387259163285524671855725511880656411741012446023392964655239624520090988149679656514996202498334816938716757663800773997302639681907686195671083505910700098597156238624351157219093280177066146218516478636356056420098245995113668018177690728654922707281126889313941750547830163078886329630807850633273613622550216189245162735650139455042125252043274668279981753287687674520319519360593091620297805736177366738063651905396783336064579717230286821545930579779462534206093794040878198825916141099864730374109311705285661056855668930671948265232862757146615431791375559792290479316263924560826544387396762768331402198937951439504767950821089741987629257538953417586416459087855138539304027013800937360598578194413362672871055543854633921502486683911956250444582746421552178164852341035733290405311280719066037175324627429434912416361334254696649419037348733709488576582107382055914938194078813926926742828297826939120316120573453588052056773875836843924877773978390546387248009519202370375478981843515393806263037580338009594022254079586380520797699651840576286033587273591899639699077044271208886940540056794360292760863657703246410020854088849880453524038877935317875884698324859548991680533307680053872403383516589028793015681082435908524045497475001609824047204954932626536311826911363867426654549346914317405110707189532251727848751560224936842128628673253616256326013555922159336370177663785738170802777550686079119049748734352584409583136667752555307842739679930698964098088960000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000)%bigQ -. - -Definition pi_4_approx_high' := -(5066193963420194617885108698600649932059391557720145469382602092416947640628637390992675949693715109726079394291478795603894419483819297806310615866892414925850691415582239745615128821983865262221858109336884967754871321668348027076234335167119885298878199925731495390387858629042311908406056230882123787019283378509712244687397013657159455607193734144010901984756727174636853404278421831024545476850410085042498464474261035780891759930905778986584183710930670670301831474144997069400304290351567959717683444430666444319233768399342338059169002790777424962570605618705584660815518973602995097110557181643034682308210788409308322071457087096445676662503017187903223859814905546579050729173916234740628466315449085686468204847296426235788544874405450791749423436215032927889914519102361378633666267941326393265376660400091389373564825046526561381561278586121772300141564909333667988204680492088607706214346458601842899721615765319505314310192693665547163360402786722105590252780194994950097926184146718893770363322073641336811404180286358079915338791029818581497746089864894356686643882883410392601500048021013346713450539807687779704798018559373507951388092945938366448668853081682176581336156031434604604833692503597621519809826880683536141897075567053733515342478008373282599947520770191238802249392773327261328133194484586433840861730959791563023761306622956165536481335792721379318928171897265310054788931201902441066997927781894934061720760080768154565282051604447333036111267534150649674590201404453202347064545359869105856798745664471694795576801148562495225166002814304124970965817043547048503388910163287916513427409193998045119986267987892522931703487420953769290650229176116308194977201080691718825944370436642709192983358059711255925052564016519597530235976618244111239816418652282585432539731271068892992142956810775762851238126881225206289553948196520384709574383566733478326330112084307565420647201107231840508040019131253750047046446929758911912155202166566751947087545292626353331520202690130850009389387290465497377022080531269511355734944672010542204118978272180881335465227900174033380001851066811103401787656367819132934758616060307366679580043123632565656840669377840733018248707250548277181001911990237151790533341326223932843775840498222236867608395855700891719880219904948672458645420169533565809609056209006342663841718949396996175294237942265325043426430990062217643279654512512640557763489491751115437780462208361129433667449740743123546232162409802316714286708788831227582498585478334315076725145986771341647015244092760289407649044493584479944044779273447198382196766547779885914425854375158084417582279211000449529495605127376707776277159376010648950025135061284601443461110447113346277147728593420397807946636800365109579479211273476195727270004743568492888900356505584731622538401071221591141889158461271000051210318027818802379539544396973228585821742794928813630781709195703717312953337431290682263448669168179857644544116657440168099166467471736180072984407514757289757495435699300593165669101965987430482600019222913485092771346963058673132443387835726110205958057187517487684058179749952286341120230051432903482992282688283815697442898155194928723360957436110770317998431272108100149791425689283090777721270428030993332057319821685391144252815655146410678839177846108260765981523812232294638190350688210999605869296307711846463311346627138400477211801219366400312514793356564308532012682051019030257269068628100171220662165246389309014292764479226570049772046255291379151017129899157296574099437276707879597755725339406865738613810979022640265737120949077721294633786520294559343155148383011293584240192753971366644780434237846862975993387453786681995831719537733846579480995517357440575781962659282856696638992709756358478461648462532279323701121386551383509193782388241965285971965887701816406255233933761008649762854363984142178331798953040874526844255758512982810004271235810681505829473926495256537353108899526434200682024946218302499640511518360332022463196599199779172637638655415918976955930735312156870786600023896830267884391447789311101069654521354446521135407720085038662159974712373018912537116964809382149581004863115431780452188813210275393919111435118030412595133958954313836191108258769640843644195537185904547405641078708492098917460393911427237155683288565433183738513871595286090814836422982384810033331519971102974091067660369548406192526284519976668985518575216481570167748402860759832933071281814538397923687510782620605409323050353840034866296214149657376249634795555007199540807313397329050410326609108411299737760271566308288500400587417017113933243099961248847368789383209110747378488312550109911605079801570534271874115018095746872468910162721975463388518648962869080447866370484866697404176437230771558469231403088139693477706784802801265075586678597768511791952562627345622499328 - # 100788726492580594349650258277496659410917619472657560321971265983799894639441017438166498752997098978003489632843381325240982516059309714013145358125224597827602157516585886911710102182473475545864474089191789296685473601331678556438310133356793199956062857423397512495293688453655805536015029176541424005214818033707522950635262669828538132795615008381824067071229426026518897202246241637377064076189277685257166926338187911595052586669184297526234794666364657344206795357967279911782849686515024121916258300642000317525374433525235296287037535618423661645124459323811792936193272341688261801253469089129439519903538495370298752436267926761998785090092411372633429302950606054074205533246665546979112178855223925266166034953000200646676762301817000435641690517142795144469005596172113586738287118865058604922865654348297975054956781513943444060257230946224520058527667925776273088622386666860662470481606622952298649177217986593047495967209669116410592230626047083795555559776477430548946990993890380787911273437967786556742804566652408275798339221179283430482118140020742719695900657696142739101628984271513292954605191778803974738871043737934546460016184719168074062912083778327025499841998124431899131874519812228674255796948879306477894924710085384116453080236862135706628989104070747737689294987000148388110561753028594988959655591699155508380909698460304884908709246116411180876105681720036833487450945730831039969246996849503525429840196651386469599438064049723005123629385485140945945416764414133189625489032807860400751723995946290581976152580477047961138617997133510128194027510895265424780627975864980749945631413855375897945293107842908479797077570371447220506451229526132919408351287454305932886749170523056147842439813407002950370505941417426433452282518739345666494683448699945734453214481915512562995906034771246088038719298959180199052759295868161570318718927430655393250250811804905393113074074574608255523847592006804881016594060188745212933427473833239777228852952217878690668413947367586040297784502192683200664398064682201012931468052982448022330449955215606614483165425935154496289535573901139223034819824408001205784146243892228030383941863746839845526558421740316887532141893650230936137269356278754487130882868595412163277284772124736531380334814212708066069618080153747333573454834500999083737284449542481264971030785043701582134343596645346132964567391370300568578875509971483039720438955919863275044932311289587494336123538202079503922025306586828117649623642521324286648529829664567232756108169459356549144779085080036654897525078792273443307070502103724611233768453196294899770515940520895908289018412144327894912660060761908970811602375085884115384049610753387776858733798341463052471017393165656926510611173543365663267563198760597092606598728110197523695339144204179424646442294307593146446562536865057987897899655645968129515654148044008249646703504419478535298270862753806142083172190778193001810574370442181909146645889199829207284871551220439225371051511970054965951914399901815408791418836185742573331879114400013259342896515702942707292473805188905427717363630137869116872433627556880809120353079342030725196065815470427569172350436988386579444534375353968759750750178342190349607711313840613843718547859929387259163285524671855725511880656411741012446023392964655239624520090988149679656514996202498334816938716757663800773997302639681907686195671083505910700098597156238624351157219093280177066146218516478636356056420098245995113668018177690728654922707281126889313941750547830163078886329630807850633273613622550216189245162735650139455042125252043274668279981753287687674520319519360593091620297805736177366738063651905396783336064579717230286821545930579779462534206093794040878198825916141099864730374109311705285661056855668930671948265232862757146615431791375559792290479316263924560826544387396762768331402198937951439504767950821089741987629257538953417586416459087855138539304027013800937360598578194413362672871055543854633921502486683911956250444582746421552178164852341035733290405311280719066037175324627429434912416361334254696649419037348733709488576582107382055914938194078813926926742828297826939120316120573453588052056773875836843924877773978390546387248009519202370375478981843515393806263037580338009594022254079586380520797699651840576286033587273591899639699077044271208886940540056794360292760863657703246410020854088849880453524038877935317875884698324859548991680533307680053872403383516589028793015681082435908524045497475001609824047204954932626536311826911363867426654549346914317405110707189532251727848751560224936842128628673253616256326013555922159336370177663785738170802777550686079119049748734352584409583136667752555307842739679930698964098088960000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000)%bigQ -. - -Fixpoint numden_Rcontfrac_tailrecB (accu: list bigZ) (n1 d1: bigZ) (n2 d2: bigZ) (fuel: nat) {struct fuel}: - (list bigZ * bigQ * bigQ) := - let default := (rev_append accu nil, BigQ.div (BigQ.Qz n1) (BigQ.Qz d1), BigQ.div (BigQ.Qz n2) (BigQ.Qz d2)) in - match fuel with - | O => default - | S fuel' => - let '(q1, r1) := BigZ.div_eucl n1 d1 in - let '(q2, r2) := BigZ.div_eucl n2 d2 in - match BigZ.eqb q1 q2 with - | false => default - | true => - let r1_is_zero := BigZ.eqb r1 0 in - let r2_is_zero := BigZ.eqb r2 0 in - match Bool.eqb r1_is_zero r2_is_zero with - | false => default - | true => - match r1_is_zero with - | true => - match BigZ.eqb q1 1 with - | true => (rev_append accu nil, 1%bigQ, 1%bigQ) - | false => (rev_append ((q1 - 1)%bigZ :: accu) nil, 1%bigQ, 1%bigQ) - end - | false => numden_Rcontfrac_tailrecB (q1 :: accu) d1 r1 d2 r2 fuel' - end - end - end - end. - -Definition Bnum b := - match b with - | BigQ.Qz t => t - | BigQ.Qq n d => - if (d =? BigN.zero)%bigN then 0%bigZ else n - end. - -Definition Bden b := - match b with - | BigQ.Qz _ => 1%bigN - | BigQ.Qq _ d => if (d =? BigN.zero)%bigN then 1%bigN else d - end. - -Definition rat_Rcontfrac_tailrecB q1 q2 := - numden_Rcontfrac_tailrecB nil (Bnum q1) (BigZ.Pos (Bden q1)) (Bnum q2) (BigZ.Pos (Bden q2)). - -Definition pi_4_contfrac := - rat_Rcontfrac_tailrecB pi_4_approx_low' pi_4_approx_high' 3000. - -(* The following used to fail because of a non canonical representation of 0 in -the bytecode interpreter. Bug reported privately by Tahina Ramananandro. *) -Goal pi_4_contfrac = pi_4_contfrac. -vm_compute. -reflexivity. -Qed. diff --git a/test-suite/success/cumulativity.v b/test-suite/success/cumulativity.v new file mode 100644 index 0000000000..ebf817cfc5 --- /dev/null +++ b/test-suite/success/cumulativity.v @@ -0,0 +1,65 @@ +Set Universe Polymorphism. +Set Inductive Cumulativity. +Set Printing Universes. + +Inductive List (A: Type) := nil | cons : A -> List A -> List A. + +Section ListLift. + Universe i j. + + Constraint i < j. + + Definition LiftL {A} : List@{i} A -> List@{j} A := fun x => x. + +End ListLift. + +Lemma LiftL_Lem A (l : List A) : l = LiftL l. +Proof. reflexivity. Qed. + +Section ListLower. + Universe i j. + + Constraint i < j. + + Definition LowerL {A : Type@{i}} : List@{j} A -> List@{i} A := fun x => x. + +End ListLower. + +Lemma LowerL_Lem@{i j} (A : Type@{j}) (l : List@{i} A) : l = LowerL l. +Proof. reflexivity. Qed. + +Inductive Tp := tp : Type -> Tp. + +Section TpLift. + Universe i j. + + Constraint i < j. + + Definition LiftTp : Tp@{i} -> Tp@{j} := fun x => x. + +End TpLift. + +Lemma LiftC_Lem (t : Tp) : LiftTp t = t. +Proof. reflexivity. Qed. + +Section TpLower. + Universe i j. + + Constraint i < j. + + Fail Definition LowerTp : Tp@{j} -> Tp@{i} := fun x => x. + +End TpLower. + + +Section subtyping_test. + Universe i j. + Constraint i < j. + + Inductive TP2 := tp2 : Type@{i} -> Type@{j} -> TP2. + +End subtyping_test. + +Record A : Type := { a :> Type; }. + +Record B (X : A) : Type := { b : X; }.
\ No newline at end of file diff --git a/test-suite/success/extraction.v b/test-suite/success/extraction.v index 0086e090bd..89be144152 100644 --- a/test-suite/success/extraction.v +++ b/test-suite/success/extraction.v @@ -6,6 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +Require Coq.extraction.Extraction. Require Import Arith. Require Import List. diff --git a/test-suite/success/extraction_dep.v b/test-suite/success/extraction_dep.v index 11bb25fda0..e770cf779a 100644 --- a/test-suite/success/extraction_dep.v +++ b/test-suite/success/extraction_dep.v @@ -1,6 +1,8 @@ (** Examples of code elimination inside modules during extraction *) +Require Coq.extraction.Extraction. + (** NB: we should someday check the produced code instead of simply running the commands. *) diff --git a/test-suite/success/extraction_impl.v b/test-suite/success/extraction_impl.v index dfdeff82ff..5bf807b1c6 100644 --- a/test-suite/success/extraction_impl.v +++ b/test-suite/success/extraction_impl.v @@ -4,6 +4,8 @@ (** NB: we should someday check the produced code instead of simply running the commands. *) +Require Coq.extraction.Extraction. + (** Bug #4243, part 1 *) Inductive dnat : nat -> Type := diff --git a/test-suite/success/extraction_polyprop.v b/test-suite/success/extraction_polyprop.v index 7215bd9905..936d838c50 100644 --- a/test-suite/success/extraction_polyprop.v +++ b/test-suite/success/extraction_polyprop.v @@ -3,6 +3,8 @@ code that segfaults. See Table.error_singleton_become_prop or S. Glondu's thesis for more details. *) +Require Coq.extraction.Extraction. + Definition f {X} (p : (nat -> X) * True) : X * nat := (fst p 0, 0). diff --git a/test-suite/success/polymorphism.v b/test-suite/success/polymorphism.v index 66ff55edcb..ecc988507c 100644 --- a/test-suite/success/polymorphism.v +++ b/test-suite/success/polymorphism.v @@ -352,3 +352,35 @@ Module Anonymous. Check collapsethemiddle@{_ _}. End Anonymous. + +Module F. + Context {A B : Type}. + Definition foo : Type := B. +End F. + +Set Universe Polymorphism. + +Cumulative Record box (X : Type) (T := Type) : Type := wrap { unwrap : T }. + +Section test_letin_subtyping. + Universe i j k i' j' k'. + Constraint j < j'. + + Context (W : Type) (X : box@{i j k} W). + Definition Y := X : box@{i' j' k'} W. + + Universe i1 j1 k1 i2 j2 k2. + Constraint i1 < i2. + Constraint k2 < k1. + Context (V : Type). + + Definition Z : box@{i1 j1 k1} V := {| unwrap := V |}. + Definition Z' : box@{i2 j2 k2} V := {| unwrap := V |}. + Lemma ZZ' : @eq (box@{i2 j2 k2} V) Z Z'. + Proof. + Set Printing All. Set Printing Universes. + cbv. + reflexivity. + Qed. + +End test_letin_subtyping. diff --git a/test-suite/success/primitiveproj.v b/test-suite/success/primitiveproj.v index 2fa7704941..789854b2d6 100644 --- a/test-suite/success/primitiveproj.v +++ b/test-suite/success/primitiveproj.v @@ -181,6 +181,8 @@ Record wrap (A : Type) := { unwrap : A; unwrap2 : A }. Definition term (x : wrap nat) := x.(unwrap). Definition term' (x : wrap nat) := let f := (@unwrap2 nat) in f x. + +Require Coq.extraction.Extraction. Recursive Extraction term term'. (*Unset Printing Primitive Projection Parameters.*) diff --git a/theories/Classes/CRelationClasses.v b/theories/Classes/CRelationClasses.v index 3d7ef01fb1..cfe0e08edb 100644 --- a/theories/Classes/CRelationClasses.v +++ b/theories/Classes/CRelationClasses.v @@ -305,9 +305,7 @@ Section Binary. fun x y => sum (R x y) (R' x y). (** Relation equivalence is an equivalence, and subrelation defines a partial order. *) - - Set Automatic Introduction. - + Global Instance relation_equivalence_equivalence : Equivalence relation_equivalence. Proof. split; red; unfold relation_equivalence, iffT. firstorder. diff --git a/theories/Classes/RelationClasses.v b/theories/Classes/RelationClasses.v index 11c204dae5..57728d305d 100644 --- a/theories/Classes/RelationClasses.v +++ b/theories/Classes/RelationClasses.v @@ -433,9 +433,7 @@ Section Binary. @predicate_union (A::A::Tnil) R R'. (** Relation equivalence is an equivalence, and subrelation defines a partial order. *) - - Set Automatic Introduction. - + Global Instance relation_equivalence_equivalence : Equivalence relation_equivalence. Proof. exact (@predicate_equivalence_equivalence (A::A::Tnil)). Qed. diff --git a/theories/Compat/Coq84.v b/theories/Compat/Coq84.v deleted file mode 100644 index a3e23f91c9..0000000000 --- a/theories/Compat/Coq84.v +++ /dev/null @@ -1,79 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(** Compatibility file for making Coq act similar to Coq v8.4 *) - -(** Any compatibility changes to make future versions of Coq behave like Coq 8.5 are likely needed to make them behave like Coq 8.4. *) -Require Export Coq.Compat.Coq85. - -(** See https://coq.inria.fr/bugs/show_bug.cgi?id=4319 for updates *) -(** This is required in Coq 8.5 to use the [omega] tactic; in Coq 8.4, it's automatically available. But ZArith_base puts infix ~ at level 7, and we don't want that, so we don't [Import] it. *) -Require Coq.omega.Omega. -Ltac omega := Coq.omega.Omega.omega. - -(** The number of arguments given in [match] statements has changed from 8.4 to 8.5. *) -Global Set Asymmetric Patterns. - -(** The automatic elimination schemes for records were dropped by default in 8.5. This restores the default behavior of Coq 8.4. *) -Global Set Nonrecursive Elimination Schemes. - -(** See bug 3545 *) -Global Set Universal Lemma Under Conjunction. - -(** Feature introduced in 8.5, disabled by default and configurable since 8.6. *) -Global Unset Refolding Reduction. - -(** In 8.4, [constructor (tac)] allowed backtracking across the use of [constructor]; it has been subsumed by [constructor; tac]. *) -Ltac constructor_84_n n := constructor n. -Ltac constructor_84_tac tac := once (constructor; tac). - -Tactic Notation "constructor" := Coq.Init.Notations.constructor. -Tactic Notation "constructor" int_or_var(n) := constructor_84_n n. -Tactic Notation "constructor" "(" tactic(tac) ")" := constructor_84_tac tac. - -(** In 8.4, [econstructor (tac)] allowed backtracking across the use of [econstructor]; it has been subsumed by [econstructor; tac]. *) -Ltac econstructor_84_n n := econstructor n. -Ltac econstructor_84_tac tac := once (econstructor; tac). - -Tactic Notation "econstructor" := Coq.Init.Notations.econstructor. -Tactic Notation "econstructor" int_or_var(n) := econstructor_84_n n. -Tactic Notation "econstructor" "(" tactic(tac) ")" := econstructor_84_tac tac. - -(** Some tactic notations do not factor well with tactics; we add global parsing entries for some tactics that would otherwise be overwritten by custom variants. See https://coq.inria.fr/bugs/show_bug.cgi?id=4392. *) -Tactic Notation "reflexivity" := reflexivity. -Tactic Notation "assumption" := assumption. -Tactic Notation "etransitivity" := etransitivity. -Tactic Notation "cut" constr(c) := cut c. -Tactic Notation "exact_no_check" constr(c) := exact_no_check c. -Tactic Notation "vm_cast_no_check" constr(c) := vm_cast_no_check c. -Tactic Notation "casetype" constr(c) := casetype c. -Tactic Notation "elimtype" constr(c) := elimtype c. -Tactic Notation "lapply" constr(c) := lapply c. -Tactic Notation "transitivity" constr(c) := transitivity c. -Tactic Notation "left" := left. -Tactic Notation "eleft" := eleft. -Tactic Notation "right" := right. -Tactic Notation "eright" := eright. -Tactic Notation "symmetry" := symmetry. -Tactic Notation "split" := split. -Tactic Notation "esplit" := esplit. - -(** Many things now import [PeanoNat] rather than [NPeano], so we require it so that the old absolute names in [NPeano.Nat] are available. *) -Require Coq.Numbers.Natural.Peano.NPeano. - -(** The following coercions were declared by default in Specif.v. *) -Coercion sig_of_sig2 : sig2 >-> sig. -Coercion sigT_of_sigT2 : sigT2 >-> sigT. -Coercion sigT_of_sig : sig >-> sigT. -Coercion sig_of_sigT : sigT >-> sig. -Coercion sigT2_of_sig2 : sig2 >-> sigT2. -Coercion sig2_of_sigT2 : sigT2 >-> sig2. - -(** In 8.4, the statement of admitted lemmas did not depend on the section - variables. *) -Unset Keep Admitted Variables. diff --git a/theories/Compat/Coq85.v b/theories/Compat/Coq85.v index 64ba6b1e30..b30ad1af88 100644 --- a/theories/Compat/Coq85.v +++ b/theories/Compat/Coq85.v @@ -34,3 +34,6 @@ Global Unset Typeclasses Filtered Unification. (** Allow silently letting unification constraints float after a "." *) Global Unset Solve Unification Constraints. + +Require Export Coq.extraction.Extraction. +Require Export Coq.funind.FunInd. diff --git a/theories/FSets/FMapAVL.v b/theories/FSets/FMapAVL.v index c9e5b8dd20..4a790296bb 100644 --- a/theories/FSets/FMapAVL.v +++ b/theories/FSets/FMapAVL.v @@ -16,7 +16,7 @@ See the comments at the beginning of FSetAVL for more details. *) -Require Import FMapInterface FMapList ZArith Int. +Require Import FunInd FMapInterface FMapList ZArith Int. Set Implicit Arguments. Unset Strict Implicit. diff --git a/theories/FSets/FMapFullAVL.v b/theories/FSets/FMapFullAVL.v index a7be32328d..b8e362f159 100644 --- a/theories/FSets/FMapFullAVL.v +++ b/theories/FSets/FMapFullAVL.v @@ -25,7 +25,7 @@ *) -Require Import Recdef FMapInterface FMapList ZArith Int FMapAVL ROmega. +Require Import FunInd Recdef FMapInterface FMapList ZArith Int FMapAVL ROmega. Set Implicit Arguments. Unset Strict Implicit. diff --git a/theories/FSets/FMapList.v b/theories/FSets/FMapList.v index 5acdb7eb7e..aadef476d7 100644 --- a/theories/FSets/FMapList.v +++ b/theories/FSets/FMapList.v @@ -12,7 +12,7 @@ [FMapInterface.S] using lists of pairs ordered (increasing) with respect to left projection. *) -Require Import FMapInterface. +Require Import FunInd FMapInterface. Set Implicit Arguments. Unset Strict Implicit. diff --git a/theories/FSets/FMapWeakList.v b/theories/FSets/FMapWeakList.v index 130cbee871..8124097020 100644 --- a/theories/FSets/FMapWeakList.v +++ b/theories/FSets/FMapWeakList.v @@ -11,7 +11,7 @@ (** This file proposes an implementation of the non-dependent interface [FMapInterface.WS] using lists of pairs, unordered but without redundancy. *) -Require Import FMapInterface. +Require Import FunInd FMapInterface. Set Implicit Arguments. Unset Strict Implicit. diff --git a/theories/Init/Logic.v b/theories/Init/Logic.v index 3eefe9a849..4db11ae77d 100644 --- a/theories/Init/Logic.v +++ b/theories/Init/Logic.v @@ -313,8 +313,8 @@ Arguments eq_ind [A] x P _ y _. Arguments eq_rec [A] x P _ y _. Arguments eq_rect [A] x P _ y _. -Hint Resolve I conj or_introl or_intror : core. -Hint Resolve eq_refl: core. +Hint Resolve I conj or_introl or_intror : core. +Hint Resolve eq_refl: core. Hint Resolve ex_intro ex_intro2: core. Section Logic_lemmas. @@ -504,6 +504,11 @@ Proof. reflexivity. Defined. +Lemma eq_refl_map_distr : forall A B x (f:A->B), f_equal f (eq_refl x) = eq_refl (f x). +Proof. + reflexivity. +Qed. + Lemma eq_trans_map_distr : forall A B x y z (f:A->B) (e:x=y) (e':y=z), f_equal f (eq_trans e e') = eq_trans (f_equal f e) (f_equal f e'). Proof. destruct e'. @@ -522,6 +527,19 @@ destruct e, e'. reflexivity. Defined. +Lemma eq_trans_rew_distr : forall A (P:A -> Type) (x y z:A) (e:x=y) (e':y=z) (k:P x), + rew (eq_trans e e') in k = rew e' in rew e in k. +Proof. + destruct e, e'; reflexivity. +Qed. + +Lemma rew_const : forall A P (x y:A) (e:x=y) (k:P), + rew [fun _ => P] e in k = k. +Proof. + destruct e; reflexivity. +Qed. + + (* Aliases *) Notation sym_eq := eq_sym (compat "8.3"). @@ -575,7 +593,7 @@ Proof. assert (H : x0 = x1) by (transitivity x; [symmetry|]; auto). destruct H. assumption. -Qed. +Qed. Lemma forall_exists_coincide_unique_domain : forall A (P:A->Prop), @@ -587,7 +605,7 @@ Proof. exists x. split; [trivial|]. destruct H with (Q:=fun x'=>x=x') as (_,Huniq). apply Huniq. exists x; auto. -Qed. +Qed. (** * Being inhabited *) @@ -631,3 +649,97 @@ Qed. Declare Left Step iff_stepl. Declare Right Step iff_trans. + +Local Notation "'rew' 'dependent' H 'in' H'" + := (match H with + | eq_refl => H' + end) + (at level 10, H' at level 10, + format "'[' 'rew' 'dependent' '/ ' H in '/' H' ']'"). + +(** Equality for [ex] *) +Section ex. + Local Unset Implicit Arguments. + Definition eq_ex_uncurried {A : Type} (P : A -> Prop) {u1 v1 : A} {u2 : P u1} {v2 : P v1} + (pq : exists p : u1 = v1, rew p in u2 = v2) + : ex_intro P u1 u2 = ex_intro P v1 v2. + Proof. + destruct pq as [p q]. + destruct q; simpl in *. + destruct p; reflexivity. + Qed. + + Definition eq_ex {A : Type} {P : A -> Prop} (u1 v1 : A) (u2 : P u1) (v2 : P v1) + (p : u1 = v1) (q : rew p in u2 = v2) + : ex_intro P u1 u2 = ex_intro P v1 v2 + := eq_ex_uncurried P (ex_intro _ p q). + + Definition eq_ex_hprop {A} {P : A -> Prop} (P_hprop : forall (x : A) (p q : P x), p = q) + (u1 v1 : A) (u2 : P u1) (v2 : P v1) + (p : u1 = v1) + : ex_intro P u1 u2 = ex_intro P v1 v2 + := eq_ex u1 v1 u2 v2 p (P_hprop _ _ _). + + Lemma rew_ex {A x} {P : A -> Type} (Q : forall a, P a -> Prop) (u : exists p, Q x p) {y} (H : x = y) + : rew [fun a => exists p, Q a p] H in u + = match u with + | ex_intro _ u1 u2 + => ex_intro + (Q y) + (rew H in u1) + (rew dependent H in u2) + end. + Proof. + destruct H, u; reflexivity. + Qed. +End ex. + +(** Equality for [ex2] *) +Section ex2. + Local Unset Implicit Arguments. + + Definition eq_ex2_uncurried {A : Type} (P Q : A -> Prop) {u1 v1 : A} + {u2 : P u1} {v2 : P v1} + {u3 : Q u1} {v3 : Q v1} + (pq : exists2 p : u1 = v1, rew p in u2 = v2 & rew p in u3 = v3) + : ex_intro2 P Q u1 u2 u3 = ex_intro2 P Q v1 v2 v3. + Proof. + destruct pq as [p q r]. + destruct r, q, p; simpl in *. + reflexivity. + Qed. + + Definition eq_ex2 {A : Type} {P Q : A -> Prop} + (u1 v1 : A) + (u2 : P u1) (v2 : P v1) + (u3 : Q u1) (v3 : Q v1) + (p : u1 = v1) (q : rew p in u2 = v2) (r : rew p in u3 = v3) + : ex_intro2 P Q u1 u2 u3 = ex_intro2 P Q v1 v2 v3 + := eq_ex2_uncurried P Q (ex_intro2 _ _ p q r). + + Definition eq_ex2_hprop {A} {P Q : A -> Prop} + (P_hprop : forall (x : A) (p q : P x), p = q) + (Q_hprop : forall (x : A) (p q : Q x), p = q) + (u1 v1 : A) (u2 : P u1) (v2 : P v1) (u3 : Q u1) (v3 : Q v1) + (p : u1 = v1) + : ex_intro2 P Q u1 u2 u3 = ex_intro2 P Q v1 v2 v3 + := eq_ex2 u1 v1 u2 v2 u3 v3 p (P_hprop _ _ _) (Q_hprop _ _ _). + + Lemma rew_ex2 {A x} {P : A -> Type} + (Q : forall a, P a -> Prop) + (R : forall a, P a -> Prop) + (u : exists2 p, Q x p & R x p) {y} (H : x = y) + : rew [fun a => exists2 p, Q a p & R a p] H in u + = match u with + | ex_intro2 _ _ u1 u2 u3 + => ex_intro2 + (Q y) + (R y) + (rew H in u1) + (rew dependent H in u2) + (rew dependent H in u3) + end. + Proof. + destruct H, u; reflexivity. + Qed. +End ex2. diff --git a/theories/Init/Prelude.v b/theories/Init/Prelude.v index e71a8774ed..28049e9ee5 100644 --- a/theories/Init/Prelude.v +++ b/theories/Init/Prelude.v @@ -18,9 +18,7 @@ Require Export Coq.Init.Tactics. Require Export Coq.Init.Tauto. (* Initially available plugins (+ nat_syntax_plugin loaded in Datatypes) *) -Declare ML Module "extraction_plugin". Declare ML Module "cc_plugin". Declare ML Module "ground_plugin". -Declare ML Module "recdef_plugin". (* Default substrings not considered by queries like SearchAbout *) Add Search Blacklist "_subproof" "_subterm" "Private_". diff --git a/theories/Init/Specif.v b/theories/Init/Specif.v index 43a441fc51..95734991d6 100644 --- a/theories/Init/Specif.v +++ b/theories/Init/Specif.v @@ -218,6 +218,407 @@ Proof. intros [[x y]];exists x;exact y. Qed. +(** Equality of sigma types *) +Import EqNotations. +Local Notation "'rew' 'dependent' H 'in' H'" + := (match H with + | eq_refl => H' + end) + (at level 10, H' at level 10, + format "'[' 'rew' 'dependent' '/ ' H in '/' H' ']'"). + +(** Equality for [sigT] *) +Section sigT. + Local Unset Implicit Arguments. + (** Projecting an equality of a pair to equality of the first components *) + Definition projT1_eq {A} {P : A -> Type} {u v : { a : A & P a }} (p : u = v) + : projT1 u = projT1 v + := f_equal (@projT1 _ _) p. + + (** Projecting an equality of a pair to equality of the second components *) + Definition projT2_eq {A} {P : A -> Type} {u v : { a : A & P a }} (p : u = v) + : rew projT1_eq p in projT2 u = projT2 v + := rew dependent p in eq_refl. + + (** Equality of [sigT] is itself a [sigT] (forwards-reasoning version) *) + Definition eq_existT_uncurried {A : Type} {P : A -> Type} {u1 v1 : A} {u2 : P u1} {v2 : P v1} + (pq : { p : u1 = v1 & rew p in u2 = v2 }) + : existT _ u1 u2 = existT _ v1 v2. + Proof. + destruct pq as [p q]. + destruct q; simpl in *. + destruct p; reflexivity. + Defined. + + (** Equality of [sigT] is itself a [sigT] (backwards-reasoning version) *) + Definition eq_sigT_uncurried {A : Type} {P : A -> Type} (u v : { a : A & P a }) + (pq : { p : projT1 u = projT1 v & rew p in projT2 u = projT2 v }) + : u = v. + Proof. + destruct u as [u1 u2], v as [v1 v2]; simpl in *. + apply eq_existT_uncurried; exact pq. + Defined. + + (** Curried version of proving equality of sigma types *) + Definition eq_sigT {A : Type} {P : A -> Type} (u v : { a : A & P a }) + (p : projT1 u = projT1 v) (q : rew p in projT2 u = projT2 v) + : u = v + := eq_sigT_uncurried u v (existT _ p q). + + (** Equality of [sigT] when the property is an hProp *) + Definition eq_sigT_hprop {A P} (P_hprop : forall (x : A) (p q : P x), p = q) + (u v : { a : A & P a }) + (p : projT1 u = projT1 v) + : u = v + := eq_sigT u v p (P_hprop _ _ _). + + (** Equivalence of equality of [sigT] with a [sigT] of equality *) + (** We could actually prove an isomorphism here, and not just [<->], + but for simplicity, we don't. *) + Definition eq_sigT_uncurried_iff {A P} + (u v : { a : A & P a }) + : u = v <-> { p : projT1 u = projT1 v & rew p in projT2 u = projT2 v }. + Proof. + split; [ intro; subst; exists eq_refl; reflexivity | apply eq_sigT_uncurried ]. + Defined. + + (** Induction principle for [@eq (sigT _)] *) + Definition eq_sigT_rect {A P} {u v : { a : A & P a }} (Q : u = v -> Type) + (f : forall p q, Q (eq_sigT u v p q)) + : forall p, Q p. + Proof. intro p; specialize (f (projT1_eq p) (projT2_eq p)); destruct u, p; exact f. Defined. + Definition eq_sigT_rec {A P u v} (Q : u = v :> { a : A & P a } -> Set) := eq_sigT_rect Q. + Definition eq_sigT_ind {A P u v} (Q : u = v :> { a : A & P a } -> Prop) := eq_sigT_rec Q. + + (** Equivalence of equality of [sigT] involving hProps with equality of the first components *) + Definition eq_sigT_hprop_iff {A P} (P_hprop : forall (x : A) (p q : P x), p = q) + (u v : { a : A & P a }) + : u = v <-> (projT1 u = projT1 v) + := conj (fun p => f_equal (@projT1 _ _) p) (eq_sigT_hprop P_hprop u v). + + (** Non-dependent classification of equality of [sigT] *) + Definition eq_sigT_nondep {A B : Type} (u v : { a : A & B }) + (p : projT1 u = projT1 v) (q : projT2 u = projT2 v) + : u = v + := @eq_sigT _ _ u v p (eq_trans (rew_const _ _) q). + + (** Classification of transporting across an equality of [sigT]s *) + Lemma rew_sigT {A x} {P : A -> Type} (Q : forall a, P a -> Prop) (u : { p : P x & Q x p }) {y} (H : x = y) + : rew [fun a => { p : P a & Q a p }] H in u + = existT + (Q y) + (rew H in projT1 u) + (rew dependent H in (projT2 u)). + Proof. + destruct H, u; reflexivity. + Defined. +End sigT. + +(** Equality for [sig] *) +Section sig. + Local Unset Implicit Arguments. + (** Projecting an equality of a pair to equality of the first components *) + Definition proj1_sig_eq {A} {P : A -> Prop} {u v : { a : A | P a }} (p : u = v) + : proj1_sig u = proj1_sig v + := f_equal (@proj1_sig _ _) p. + + (** Projecting an equality of a pair to equality of the second components *) + Definition proj2_sig_eq {A} {P : A -> Prop} {u v : { a : A | P a }} (p : u = v) + : rew proj1_sig_eq p in proj2_sig u = proj2_sig v + := rew dependent p in eq_refl. + + (** Equality of [sig] is itself a [sig] (forwards-reasoning version) *) + Definition eq_exist_uncurried {A : Type} {P : A -> Prop} {u1 v1 : A} {u2 : P u1} {v2 : P v1} + (pq : { p : u1 = v1 | rew p in u2 = v2 }) + : exist _ u1 u2 = exist _ v1 v2. + Proof. + destruct pq as [p q]. + destruct q; simpl in *. + destruct p; reflexivity. + Defined. + + (** Equality of [sig] is itself a [sig] (backwards-reasoning version) *) + Definition eq_sig_uncurried {A : Type} {P : A -> Prop} (u v : { a : A | P a }) + (pq : { p : proj1_sig u = proj1_sig v | rew p in proj2_sig u = proj2_sig v }) + : u = v. + Proof. + destruct u as [u1 u2], v as [v1 v2]; simpl in *. + apply eq_exist_uncurried; exact pq. + Defined. + + (** Curried version of proving equality of sigma types *) + Definition eq_sig {A : Type} {P : A -> Prop} (u v : { a : A | P a }) + (p : proj1_sig u = proj1_sig v) (q : rew p in proj2_sig u = proj2_sig v) + : u = v + := eq_sig_uncurried u v (exist _ p q). + + (** Induction principle for [@eq (sig _)] *) + Definition eq_sig_rect {A P} {u v : { a : A | P a }} (Q : u = v -> Type) + (f : forall p q, Q (eq_sig u v p q)) + : forall p, Q p. + Proof. intro p; specialize (f (proj1_sig_eq p) (proj2_sig_eq p)); destruct u, p; exact f. Defined. + Definition eq_sig_rec {A P u v} (Q : u = v :> { a : A | P a } -> Set) := eq_sig_rect Q. + Definition eq_sig_ind {A P u v} (Q : u = v :> { a : A | P a } -> Prop) := eq_sig_rec Q. + + (** Equality of [sig] when the property is an hProp *) + Definition eq_sig_hprop {A} {P : A -> Prop} (P_hprop : forall (x : A) (p q : P x), p = q) + (u v : { a : A | P a }) + (p : proj1_sig u = proj1_sig v) + : u = v + := eq_sig u v p (P_hprop _ _ _). + + (** Equivalence of equality of [sig] with a [sig] of equality *) + (** We could actually prove an isomorphism here, and not just [<->], + but for simplicity, we don't. *) + Definition eq_sig_uncurried_iff {A} {P : A -> Prop} + (u v : { a : A | P a }) + : u = v <-> { p : proj1_sig u = proj1_sig v | rew p in proj2_sig u = proj2_sig v }. + Proof. + split; [ intro; subst; exists eq_refl; reflexivity | apply eq_sig_uncurried ]. + Defined. + + (** Equivalence of equality of [sig] involving hProps with equality of the first components *) + Definition eq_sig_hprop_iff {A} {P : A -> Prop} (P_hprop : forall (x : A) (p q : P x), p = q) + (u v : { a : A | P a }) + : u = v <-> (proj1_sig u = proj1_sig v) + := conj (fun p => f_equal (@proj1_sig _ _) p) (eq_sig_hprop P_hprop u v). + + Lemma rew_sig {A x} {P : A -> Type} (Q : forall a, P a -> Prop) (u : { p : P x | Q x p }) {y} (H : x = y) + : rew [fun a => { p : P a | Q a p }] H in u + = exist + (Q y) + (rew H in proj1_sig u) + (rew dependent H in proj2_sig u). + Proof. + destruct H, u; reflexivity. + Defined. +End sig. + +(** Equality for [sigT] *) +Section sigT2. + (* We make [sigT_of_sigT2] a coercion so we can use [projT1], [projT2] on [sigT2] *) + Local Coercion sigT_of_sigT2 : sigT2 >-> sigT. + Local Unset Implicit Arguments. + (** Projecting an equality of a pair to equality of the first components *) + Definition sigT_of_sigT2_eq {A} {P Q : A -> Type} {u v : { a : A & P a & Q a }} (p : u = v) + : u = v :> { a : A & P a } + := f_equal _ p. + Definition projT1_of_sigT2_eq {A} {P Q : A -> Type} {u v : { a : A & P a & Q a }} (p : u = v) + : projT1 u = projT1 v + := projT1_eq (sigT_of_sigT2_eq p). + + (** Projecting an equality of a pair to equality of the second components *) + Definition projT2_of_sigT2_eq {A} {P Q : A -> Type} {u v : { a : A & P a & Q a }} (p : u = v) + : rew projT1_of_sigT2_eq p in projT2 u = projT2 v + := rew dependent p in eq_refl. + + (** Projecting an equality of a pair to equality of the third components *) + Definition projT3_eq {A} {P Q : A -> Type} {u v : { a : A & P a & Q a }} (p : u = v) + : rew projT1_of_sigT2_eq p in projT3 u = projT3 v + := rew dependent p in eq_refl. + + (** Equality of [sigT2] is itself a [sigT2] (forwards-reasoning version) *) + Definition eq_existT2_uncurried {A : Type} {P Q : A -> Type} + {u1 v1 : A} {u2 : P u1} {v2 : P v1} {u3 : Q u1} {v3 : Q v1} + (pqr : { p : u1 = v1 + & rew p in u2 = v2 & rew p in u3 = v3 }) + : existT2 _ _ u1 u2 u3 = existT2 _ _ v1 v2 v3. + Proof. + destruct pqr as [p q r]. + destruct r, q, p; simpl. + reflexivity. + Defined. + + (** Equality of [sigT2] is itself a [sigT2] (backwards-reasoning version) *) + Definition eq_sigT2_uncurried {A : Type} {P Q : A -> Type} (u v : { a : A & P a & Q a }) + (pqr : { p : projT1 u = projT1 v + & rew p in projT2 u = projT2 v & rew p in projT3 u = projT3 v }) + : u = v. + Proof. + destruct u as [u1 u2 u3], v as [v1 v2 v3]; simpl in *. + apply eq_existT2_uncurried; exact pqr. + Defined. + + (** Curried version of proving equality of sigma types *) + Definition eq_sigT2 {A : Type} {P Q : A -> Type} (u v : { a : A & P a & Q a }) + (p : projT1 u = projT1 v) + (q : rew p in projT2 u = projT2 v) + (r : rew p in projT3 u = projT3 v) + : u = v + := eq_sigT2_uncurried u v (existT2 _ _ p q r). + + (** Equality of [sigT2] when the second property is an hProp *) + Definition eq_sigT2_hprop {A P Q} (Q_hprop : forall (x : A) (p q : Q x), p = q) + (u v : { a : A & P a & Q a }) + (p : u = v :> { a : A & P a }) + : u = v + := eq_sigT2 u v (projT1_eq p) (projT2_eq p) (Q_hprop _ _ _). + + (** Equivalence of equality of [sigT2] with a [sigT2] of equality *) + (** We could actually prove an isomorphism here, and not just [<->], + but for simplicity, we don't. *) + Definition eq_sigT2_uncurried_iff {A P Q} + (u v : { a : A & P a & Q a }) + : u = v + <-> { p : projT1 u = projT1 v + & rew p in projT2 u = projT2 v & rew p in projT3 u = projT3 v }. + Proof. + split; [ intro; subst; exists eq_refl; reflexivity | apply eq_sigT2_uncurried ]. + Defined. + + (** Induction principle for [@eq (sigT2 _ _)] *) + Definition eq_sigT2_rect {A P Q} {u v : { a : A & P a & Q a }} (R : u = v -> Type) + (f : forall p q r, R (eq_sigT2 u v p q r)) + : forall p, R p. + Proof. + intro p. + specialize (f (projT1_of_sigT2_eq p) (projT2_of_sigT2_eq p) (projT3_eq p)). + destruct u, p; exact f. + Defined. + Definition eq_sigT2_rec {A P Q u v} (R : u = v :> { a : A & P a & Q a } -> Set) := eq_sigT2_rect R. + Definition eq_sigT2_ind {A P Q u v} (R : u = v :> { a : A & P a & Q a } -> Prop) := eq_sigT2_rec R. + + (** Equivalence of equality of [sigT2] involving hProps with equality of the first components *) + Definition eq_sigT2_hprop_iff {A P Q} (Q_hprop : forall (x : A) (p q : Q x), p = q) + (u v : { a : A & P a & Q a }) + : u = v <-> (u = v :> { a : A & P a }) + := conj (fun p => f_equal (@sigT_of_sigT2 _ _ _) p) (eq_sigT2_hprop Q_hprop u v). + + (** Non-dependent classification of equality of [sigT] *) + Definition eq_sigT2_nondep {A B C : Type} (u v : { a : A & B & C }) + (p : projT1 u = projT1 v) (q : projT2 u = projT2 v) (r : projT3 u = projT3 v) + : u = v + := @eq_sigT2 _ _ _ u v p (eq_trans (rew_const _ _) q) (eq_trans (rew_const _ _) r). + + (** Classification of transporting across an equality of [sigT2]s *) + Lemma rew_sigT2 {A x} {P : A -> Type} (Q R : forall a, P a -> Prop) + (u : { p : P x & Q x p & R x p }) + {y} (H : x = y) + : rew [fun a => { p : P a & Q a p & R a p }] H in u + = existT2 + (Q y) + (R y) + (rew H in projT1 u) + (rew dependent H in projT2 u) + (rew dependent H in projT3 u). + Proof. + destruct H, u; reflexivity. + Defined. +End sigT2. + +(** Equality for [sig2] *) +Section sig2. + (* We make [sig_of_sig2] a coercion so we can use [proj1], [proj2] on [sig2] *) + Local Coercion sig_of_sig2 : sig2 >-> sig. + Local Unset Implicit Arguments. + (** Projecting an equality of a pair to equality of the first components *) + Definition sig_of_sig2_eq {A} {P Q : A -> Prop} {u v : { a : A | P a & Q a }} (p : u = v) + : u = v :> { a : A | P a } + := f_equal _ p. + Definition proj1_sig_of_sig2_eq {A} {P Q : A -> Prop} {u v : { a : A | P a & Q a }} (p : u = v) + : proj1_sig u = proj1_sig v + := proj1_sig_eq (sig_of_sig2_eq p). + + (** Projecting an equality of a pair to equality of the second components *) + Definition proj2_sig_of_sig2_eq {A} {P Q : A -> Prop} {u v : { a : A | P a & Q a }} (p : u = v) + : rew proj1_sig_of_sig2_eq p in proj2_sig u = proj2_sig v + := rew dependent p in eq_refl. + + (** Projecting an equality of a pair to equality of the third components *) + Definition proj3_sig_eq {A} {P Q : A -> Prop} {u v : { a : A | P a & Q a }} (p : u = v) + : rew proj1_sig_of_sig2_eq p in proj3_sig u = proj3_sig v + := rew dependent p in eq_refl. + + (** Equality of [sig2] is itself a [sig2] (fowards-reasoning version) *) + Definition eq_exist2_uncurried {A} {P Q : A -> Prop} + {u1 v1 : A} {u2 : P u1} {v2 : P v1} {u3 : Q u1} {v3 : Q v1} + (pqr : { p : u1 = v1 + | rew p in u2 = v2 & rew p in u3 = v3 }) + : exist2 _ _ u1 u2 u3 = exist2 _ _ v1 v2 v3. + Proof. + destruct pqr as [p q r]. + destruct r, q, p; simpl. + reflexivity. + Defined. + + (** Equality of [sig2] is itself a [sig2] (backwards-reasoning version) *) + Definition eq_sig2_uncurried {A} {P Q : A -> Prop} (u v : { a : A | P a & Q a }) + (pqr : { p : proj1_sig u = proj1_sig v + | rew p in proj2_sig u = proj2_sig v & rew p in proj3_sig u = proj3_sig v }) + : u = v. + Proof. + destruct u as [u1 u2 u3], v as [v1 v2 v3]; simpl in *. + apply eq_exist2_uncurried; exact pqr. + Defined. + + (** Curried version of proving equality of sigma types *) + Definition eq_sig2 {A} {P Q : A -> Prop} (u v : { a : A | P a & Q a }) + (p : proj1_sig u = proj1_sig v) + (q : rew p in proj2_sig u = proj2_sig v) + (r : rew p in proj3_sig u = proj3_sig v) + : u = v + := eq_sig2_uncurried u v (exist2 _ _ p q r). + + (** Equality of [sig2] when the second property is an hProp *) + Definition eq_sig2_hprop {A} {P Q : A -> Prop} (Q_hprop : forall (x : A) (p q : Q x), p = q) + (u v : { a : A | P a & Q a }) + (p : u = v :> { a : A | P a }) + : u = v + := eq_sig2 u v (proj1_sig_eq p) (proj2_sig_eq p) (Q_hprop _ _ _). + + (** Equivalence of equality of [sig2] with a [sig2] of equality *) + (** We could actually prove an isomorphism here, and not just [<->], + but for simplicity, we don't. *) + Definition eq_sig2_uncurried_iff {A P Q} + (u v : { a : A | P a & Q a }) + : u = v + <-> { p : proj1_sig u = proj1_sig v + | rew p in proj2_sig u = proj2_sig v & rew p in proj3_sig u = proj3_sig v }. + Proof. + split; [ intro; subst; exists eq_refl; reflexivity | apply eq_sig2_uncurried ]. + Defined. + + (** Induction principle for [@eq (sig2 _ _)] *) + Definition eq_sig2_rect {A P Q} {u v : { a : A | P a & Q a }} (R : u = v -> Type) + (f : forall p q r, R (eq_sig2 u v p q r)) + : forall p, R p. + Proof. + intro p. + specialize (f (proj1_sig_of_sig2_eq p) (proj2_sig_of_sig2_eq p) (proj3_sig_eq p)). + destruct u, p; exact f. + Defined. + Definition eq_sig2_rec {A P Q u v} (R : u = v :> { a : A | P a & Q a } -> Set) := eq_sig2_rect R. + Definition eq_sig2_ind {A P Q u v} (R : u = v :> { a : A | P a & Q a } -> Prop) := eq_sig2_rec R. + + (** Equivalence of equality of [sig2] involving hProps with equality of the first components *) + Definition eq_sig2_hprop_iff {A} {P Q : A -> Prop} (Q_hprop : forall (x : A) (p q : Q x), p = q) + (u v : { a : A | P a & Q a }) + : u = v <-> (u = v :> { a : A | P a }) + := conj (fun p => f_equal (@sig_of_sig2 _ _ _) p) (eq_sig2_hprop Q_hprop u v). + + (** Non-dependent classification of equality of [sig] *) + Definition eq_sig2_nondep {A} {B C : Prop} (u v : @sig2 A (fun _ => B) (fun _ => C)) + (p : proj1_sig u = proj1_sig v) (q : proj2_sig u = proj2_sig v) (r : proj3_sig u = proj3_sig v) + : u = v + := @eq_sig2 _ _ _ u v p (eq_trans (rew_const _ _) q) (eq_trans (rew_const _ _) r). + + (** Classification of transporting across an equality of [sig2]s *) + Lemma rew_sig2 {A x} {P : A -> Type} (Q R : forall a, P a -> Prop) + (u : { p : P x | Q x p & R x p }) + {y} (H : x = y) + : rew [fun a => { p : P a | Q a p & R a p }] H in u + = exist2 + (Q y) + (R y) + (rew H in proj1_sig u) + (rew dependent H in proj2_sig u) + (rew dependent H in proj3_sig u). + Proof. + destruct H, u; reflexivity. + Defined. +End sig2. + + (** [sumbool] is a boolean type equipped with the justification of their value *) diff --git a/theories/Init/Tactics.v b/theories/Init/Tactics.v index 7a846cd1b3..aab385ef75 100644 --- a/theories/Init/Tactics.v +++ b/theories/Init/Tactics.v @@ -243,3 +243,66 @@ with the actual [dependent induction] tactic. *) Tactic Notation "dependent" "induction" ident(H) := fail "To use dependent induction, first [Require Import Coq.Program.Equality.]". + +(** *** [inversion_sigma] *) +(** The built-in [inversion] will frequently leave equalities of + dependent pairs. When the first type in the pair is an hProp or + otherwise simplifies, [inversion_sigma] is useful; it will replace + the equality of pairs with a pair of equalities, one involving a + term casted along the other. This might also prove useful for + writing a version of [inversion] / [dependent destruction] which + does not lose information, i.e., does not turn a goal which is + provable into one which requires axiom K / UIP. *) +Ltac simpl_proj_exist_in H := + repeat match type of H with + | context G[proj1_sig (exist _ ?x ?p)] + => let G' := context G[x] in change G' in H + | context G[proj2_sig (exist _ ?x ?p)] + => let G' := context G[p] in change G' in H + | context G[projT1 (existT _ ?x ?p)] + => let G' := context G[x] in change G' in H + | context G[projT2 (existT _ ?x ?p)] + => let G' := context G[p] in change G' in H + | context G[proj3_sig (exist2 _ _ ?x ?p ?q)] + => let G' := context G[q] in change G' in H + | context G[projT3 (existT2 _ _ ?x ?p ?q)] + => let G' := context G[q] in change G' in H + | context G[sig_of_sig2 (@exist2 ?A ?P ?Q ?x ?p ?q)] + => let G' := context G[@exist A P x p] in change G' in H + | context G[sigT_of_sigT2 (@existT2 ?A ?P ?Q ?x ?p ?q)] + => let G' := context G[@existT A P x p] in change G' in H + end. +Ltac induction_sigma_in_using H rect := + let H0 := fresh H in + let H1 := fresh H in + induction H as [H0 H1] using (rect _ _ _ _); + simpl_proj_exist_in H0; + simpl_proj_exist_in H1. +Ltac induction_sigma2_in_using H rect := + let H0 := fresh H in + let H1 := fresh H in + let H2 := fresh H in + induction H as [H0 H1 H2] using (rect _ _ _ _ _); + simpl_proj_exist_in H0; + simpl_proj_exist_in H1; + simpl_proj_exist_in H2. +Ltac inversion_sigma_step := + match goal with + | [ H : _ = exist _ _ _ |- _ ] + => induction_sigma_in_using H @eq_sig_rect + | [ H : _ = existT _ _ _ |- _ ] + => induction_sigma_in_using H @eq_sigT_rect + | [ H : exist _ _ _ = _ |- _ ] + => induction_sigma_in_using H @eq_sig_rect + | [ H : existT _ _ _ = _ |- _ ] + => induction_sigma_in_using H @eq_sigT_rect + | [ H : _ = exist2 _ _ _ _ _ |- _ ] + => induction_sigma2_in_using H @eq_sig2_rect + | [ H : _ = existT2 _ _ _ _ _ |- _ ] + => induction_sigma2_in_using H @eq_sigT2_rect + | [ H : exist2 _ _ _ _ _ = _ |- _ ] + => induction_sigma_in_using H @eq_sig2_rect + | [ H : existT2 _ _ _ _ _ = _ |- _ ] + => induction_sigma_in_using H @eq_sigT2_rect + end. +Ltac inversion_sigma := repeat inversion_sigma_step. diff --git a/theories/MSets/MSetAVL.v b/theories/MSets/MSetAVL.v index a3c265a21f..b30cb6b565 100644 --- a/theories/MSets/MSetAVL.v +++ b/theories/MSets/MSetAVL.v @@ -31,7 +31,7 @@ code after extraction. *) -Require Import MSetInterface MSetGenTree BinInt Int. +Require Import FunInd MSetInterface MSetGenTree BinInt Int. Set Implicit Arguments. Unset Strict Implicit. diff --git a/theories/MSets/MSetGenTree.v b/theories/MSets/MSetGenTree.v index 154c2384c8..036ff1aa4b 100644 --- a/theories/MSets/MSetGenTree.v +++ b/theories/MSets/MSetGenTree.v @@ -27,7 +27,7 @@ - min_elt max_elt choose *) -Require Import Orders OrdersFacts MSetInterface PeanoNat. +Require Import FunInd Orders OrdersFacts MSetInterface PeanoNat. Local Open Scope list_scope. Local Open Scope lazy_bool_scope. diff --git a/theories/Numbers/BigNumPrelude.v b/theories/Numbers/BigNumPrelude.v deleted file mode 100644 index bd8930872c..0000000000 --- a/theories/Numbers/BigNumPrelude.v +++ /dev/null @@ -1,411 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) -(* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) -(************************************************************************) - -(** * BigNumPrelude *) - -(** Auxiliary functions & theorems used for arbitrary precision efficient - numbers. *) - - -Require Import ArithRing. -Require Export ZArith. -Require Export Znumtheory. -Require Export Zpow_facts. - -Declare ML Module "numbers_syntax_plugin". - -(* *** Nota Bene *** - All results that were general enough have been moved in ZArith. - Only remain here specialized lemmas and compatibility elements. - (P.L. 5/11/2007). -*) - - -Local Open Scope Z_scope. - -(* For compatibility of scripts, weaker version of some lemmas of Z.div *) - -Lemma Zlt0_not_eq : forall n, 0<n -> n<>0. -Proof. - auto with zarith. -Qed. - -Definition Zdiv_mult_cancel_r a b c H := Zdiv.Zdiv_mult_cancel_r a b c (Zlt0_not_eq _ H). -Definition Zdiv_mult_cancel_l a b c H := Zdiv.Zdiv_mult_cancel_r a b c (Zlt0_not_eq _ H). -Definition Z_div_plus_l a b c H := Zdiv.Z_div_plus_full_l a b c (Zlt0_not_eq _ H). - -(* Automation *) - -Hint Extern 2 (Z.le _ _) => - (match goal with - |- Zpos _ <= Zpos _ => exact (eq_refl _) -| H: _ <= ?p |- _ <= ?p => apply Z.le_trans with (2 := H) -| H: _ < ?p |- _ <= ?p => apply Z.lt_le_incl; apply Z.le_lt_trans with (2 := H) - end). - -Hint Extern 2 (Z.lt _ _) => - (match goal with - |- Zpos _ < Zpos _ => exact (eq_refl _) -| H: _ <= ?p |- _ <= ?p => apply Z.lt_le_trans with (2 := H) -| H: _ < ?p |- _ <= ?p => apply Z.le_lt_trans with (2 := H) - end). - - -Hint Resolve Z.lt_gt Z.le_ge Z_div_pos: zarith. - -(************************************** - Properties of order and product - **************************************) - - Theorem beta_lex: forall a b c d beta, - a * beta + b <= c * beta + d -> - 0 <= b < beta -> 0 <= d < beta -> - a <= c. - Proof. - intros a b c d beta H1 (H3, H4) (H5, H6). - assert (a - c < 1); auto with zarith. - apply Z.mul_lt_mono_pos_r with beta; auto with zarith. - apply Z.le_lt_trans with (d - b); auto with zarith. - rewrite Z.mul_sub_distr_r; auto with zarith. - Qed. - - Theorem beta_lex_inv: forall a b c d beta, - a < c -> 0 <= b < beta -> - 0 <= d < beta -> - a * beta + b < c * beta + d. - Proof. - intros a b c d beta H1 (H3, H4) (H5, H6). - case (Z.le_gt_cases (c * beta + d) (a * beta + b)); auto with zarith. - intros H7. contradict H1. apply Z.le_ngt. apply beta_lex with (1 := H7); auto. - Qed. - - Lemma beta_mult : forall h l beta, - 0 <= h < beta -> 0 <= l < beta -> 0 <= h*beta+l < beta^2. - Proof. - intros h l beta H1 H2;split. auto with zarith. - rewrite <- (Z.add_0_r (beta^2)); rewrite Z.pow_2_r; - apply beta_lex_inv;auto with zarith. - Qed. - - Lemma Zmult_lt_b : - forall b x y, 0 <= x < b -> 0 <= y < b -> 0 <= x * y <= b^2 - 2*b + 1. - Proof. - intros b x y (Hx1,Hx2) (Hy1,Hy2);split;auto with zarith. - apply Z.le_trans with ((b-1)*(b-1)). - apply Z.mul_le_mono_nonneg;auto with zarith. - apply Z.eq_le_incl; ring. - Qed. - - Lemma sum_mul_carry : forall xh xl yh yl wc cc beta, - 1 < beta -> - 0 <= wc < beta -> - 0 <= xh < beta -> - 0 <= xl < beta -> - 0 <= yh < beta -> - 0 <= yl < beta -> - 0 <= cc < beta^2 -> - wc*beta^2 + cc = xh*yl + xl*yh -> - 0 <= wc <= 1. - Proof. - intros xh xl yh yl wc cc beta U H1 H2 H3 H4 H5 H6 H7. - assert (H8 := Zmult_lt_b beta xh yl H2 H5). - assert (H9 := Zmult_lt_b beta xl yh H3 H4). - split;auto with zarith. - apply beta_lex with (cc) (beta^2 - 2) (beta^2); auto with zarith. - Qed. - - Theorem mult_add_ineq: forall x y cross beta, - 0 <= x < beta -> - 0 <= y < beta -> - 0 <= cross < beta -> - 0 <= x * y + cross < beta^2. - Proof. - intros x y cross beta HH HH1 HH2. - split; auto with zarith. - apply Z.le_lt_trans with ((beta-1)*(beta-1)+(beta-1)); auto with zarith. - apply Z.add_le_mono; auto with zarith. - apply Z.mul_le_mono_nonneg; auto with zarith. - rewrite ?Z.mul_sub_distr_l, ?Z.mul_sub_distr_r, Z.pow_2_r; auto with zarith. - Qed. - - Theorem mult_add_ineq2: forall x y c cross beta, - 0 <= x < beta -> - 0 <= y < beta -> - 0 <= c*beta + cross <= 2*beta - 2 -> - 0 <= x * y + (c*beta + cross) < beta^2. - Proof. - intros x y c cross beta HH HH1 HH2. - split; auto with zarith. - apply Z.le_lt_trans with ((beta-1)*(beta-1)+(2*beta-2));auto with zarith. - apply Z.add_le_mono; auto with zarith. - apply Z.mul_le_mono_nonneg; auto with zarith. - rewrite ?Z.mul_sub_distr_l, ?Z.mul_sub_distr_r, Z.pow_2_r; auto with zarith. - Qed. - -Theorem mult_add_ineq3: forall x y c cross beta, - 0 <= x < beta -> - 0 <= y < beta -> - 0 <= cross <= beta - 2 -> - 0 <= c <= 1 -> - 0 <= x * y + (c*beta + cross) < beta^2. - Proof. - intros x y c cross beta HH HH1 HH2 HH3. - apply mult_add_ineq2;auto with zarith. - split;auto with zarith. - apply Z.le_trans with (1*beta+cross);auto with zarith. - Qed. - -Hint Rewrite Z.mul_1_r Z.mul_0_r Z.mul_1_l Z.mul_0_l Z.add_0_l Z.add_0_r Z.sub_0_r: rm10. - - -(************************************** - Properties of Z.div and Z.modulo -**************************************) - -Theorem Zmod_le_first: forall a b, 0 <= a -> 0 < b -> 0 <= a mod b <= a. - Proof. - intros a b H H1;case (Z_mod_lt a b);auto with zarith;intros H2 H3;split;auto. - case (Z.le_gt_cases b a); intros H4; auto with zarith. - rewrite Zmod_small; auto with zarith. - Qed. - - - Theorem Zmod_distr: forall a b r t, 0 <= a <= b -> 0 <= r -> 0 <= t < 2 ^a -> - (2 ^a * r + t) mod (2 ^ b) = (2 ^a * r) mod (2 ^ b) + t. - Proof. - intros a b r t (H1, H2) H3 (H4, H5). - assert (t < 2 ^ b). - apply Z.lt_le_trans with (1:= H5); auto with zarith. - apply Zpower_le_monotone; auto with zarith. - rewrite Zplus_mod; auto with zarith. - rewrite Zmod_small with (a := t); auto with zarith. - apply Zmod_small; auto with zarith. - split; auto with zarith. - assert (0 <= 2 ^a * r); auto with zarith. - apply Z.add_nonneg_nonneg; auto with zarith. - match goal with |- context [?X mod ?Y] => case (Z_mod_lt X Y) end; - auto with zarith. - pattern (2 ^ b) at 2; replace (2 ^ b) with ((2 ^ b - 2 ^a) + 2 ^ a); - try ring. - apply Z.add_le_lt_mono; auto with zarith. - replace b with ((b - a) + a); try ring. - rewrite Zpower_exp; auto with zarith. - pattern (2 ^a) at 4; rewrite <- (Z.mul_1_l (2 ^a)); - try rewrite <- Z.mul_sub_distr_r. - rewrite (Z.mul_comm (2 ^(b - a))); rewrite Zmult_mod_distr_l; - auto with zarith. - rewrite (Z.mul_comm (2 ^a)); apply Z.mul_le_mono_nonneg_r; auto with zarith. - match goal with |- context [?X mod ?Y] => case (Z_mod_lt X Y) end; - auto with zarith. - Qed. - - Theorem Zmod_shift_r: - forall a b r t, 0 <= a <= b -> 0 <= r -> 0 <= t < 2 ^a -> - (r * 2 ^a + t) mod (2 ^ b) = (r * 2 ^a) mod (2 ^ b) + t. - Proof. - intros a b r t (H1, H2) H3 (H4, H5). - assert (t < 2 ^ b). - apply Z.lt_le_trans with (1:= H5); auto with zarith. - apply Zpower_le_monotone; auto with zarith. - rewrite Zplus_mod; auto with zarith. - rewrite Zmod_small with (a := t); auto with zarith. - apply Zmod_small; auto with zarith. - split; auto with zarith. - assert (0 <= 2 ^a * r); auto with zarith. - apply Z.add_nonneg_nonneg; auto with zarith. - match goal with |- context [?X mod ?Y] => case (Z_mod_lt X Y) end; - auto with zarith. - pattern (2 ^ b) at 2;replace (2 ^ b) with ((2 ^ b - 2 ^a) + 2 ^ a); try ring. - apply Z.add_le_lt_mono; auto with zarith. - replace b with ((b - a) + a); try ring. - rewrite Zpower_exp; auto with zarith. - pattern (2 ^a) at 4; rewrite <- (Z.mul_1_l (2 ^a)); - try rewrite <- Z.mul_sub_distr_r. - repeat rewrite (fun x => Z.mul_comm x (2 ^ a)); rewrite Zmult_mod_distr_l; - auto with zarith. - apply Z.mul_le_mono_nonneg_l; auto with zarith. - match goal with |- context [?X mod ?Y] => case (Z_mod_lt X Y) end; - auto with zarith. - Qed. - - Theorem Zdiv_shift_r: - forall a b r t, 0 <= a <= b -> 0 <= r -> 0 <= t < 2 ^a -> - (r * 2 ^a + t) / (2 ^ b) = (r * 2 ^a) / (2 ^ b). - Proof. - intros a b r t (H1, H2) H3 (H4, H5). - assert (Eq: t < 2 ^ b); auto with zarith. - apply Z.lt_le_trans with (1 := H5); auto with zarith. - apply Zpower_le_monotone; auto with zarith. - pattern (r * 2 ^ a) at 1; rewrite Z_div_mod_eq with (b := 2 ^ b); - auto with zarith. - rewrite <- Z.add_assoc. - rewrite <- Zmod_shift_r; auto with zarith. - rewrite (Z.mul_comm (2 ^ b)); rewrite Z_div_plus_full_l; auto with zarith. - rewrite (fun x y => @Zdiv_small (x mod y)); auto with zarith. - match goal with |- context [?X mod ?Y] => case (Z_mod_lt X Y) end; - auto with zarith. - Qed. - - - Lemma shift_unshift_mod : forall n p a, - 0 <= a < 2^n -> - 0 <= p <= n -> - a * 2^p = a / 2^(n - p) * 2^n + (a*2^p) mod 2^n. - Proof. - intros n p a H1 H2. - pattern (a*2^p) at 1;replace (a*2^p) with - (a*2^p/2^n * 2^n + a*2^p mod 2^n). - 2:symmetry;rewrite (Z.mul_comm (a*2^p/2^n));apply Z_div_mod_eq. - replace (a * 2 ^ p / 2 ^ n) with (a / 2 ^ (n - p));trivial. - replace (2^n) with (2^(n-p)*2^p). - symmetry;apply Zdiv_mult_cancel_r. - destruct H1;trivial. - cut (0 < 2^p); auto with zarith. - rewrite <- Zpower_exp. - replace (n-p+p) with n;trivial. ring. - omega. omega. - apply Z.lt_gt. apply Z.pow_pos_nonneg;auto with zarith. - Qed. - - - Lemma shift_unshift_mod_2 : forall n p a, 0 <= p <= n -> - ((a * 2 ^ (n - p)) mod (2^n) / 2 ^ (n - p)) mod (2^n) = - a mod 2 ^ p. - Proof. - intros. - rewrite Zmod_small. - rewrite Zmod_eq by (auto with zarith). - unfold Z.sub at 1. - rewrite Z_div_plus_l by (auto with zarith). - assert (2^n = 2^(n-p)*2^p). - rewrite <- Zpower_exp by (auto with zarith). - replace (n-p+p) with n; auto with zarith. - rewrite H0. - rewrite <- Zdiv_Zdiv, Z_div_mult by (auto with zarith). - rewrite (Z.mul_comm (2^(n-p))), Z.mul_assoc. - rewrite <- Z.mul_opp_l. - rewrite Z_div_mult by (auto with zarith). - symmetry; apply Zmod_eq; auto with zarith. - - remember (a * 2 ^ (n - p)) as b. - destruct (Z_mod_lt b (2^n)); auto with zarith. - split. - apply Z_div_pos; auto with zarith. - apply Zdiv_lt_upper_bound; auto with zarith. - apply Z.lt_le_trans with (2^n); auto with zarith. - rewrite <- (Z.mul_1_r (2^n)) at 1. - apply Z.mul_le_mono_nonneg; auto with zarith. - cut (0 < 2 ^ (n-p)); auto with zarith. - Qed. - - Lemma div_le_0 : forall p x, 0 <= x -> 0 <= x / 2 ^ p. - Proof. - intros p x Hle;destruct (Z_le_gt_dec 0 p). - apply Zdiv_le_lower_bound;auto with zarith. - replace (2^p) with 0. - destruct x;compute;intro;discriminate. - destruct p;trivial;discriminate. - Qed. - - Lemma div_lt : forall p x y, 0 <= x < y -> x / 2^p < y. - Proof. - intros p x y H;destruct (Z_le_gt_dec 0 p). - apply Zdiv_lt_upper_bound;auto with zarith. - apply Z.lt_le_trans with y;auto with zarith. - rewrite <- (Z.mul_1_r y);apply Z.mul_le_mono_nonneg;auto with zarith. - assert (0 < 2^p);auto with zarith. - replace (2^p) with 0. - destruct x;change (0<y);auto with zarith. - destruct p;trivial;discriminate. - Qed. - - Theorem Zgcd_div_pos a b: - 0 < b -> 0 < Z.gcd a b -> 0 < b / Z.gcd a b. - Proof. - intros Hb Hg. - assert (H : 0 <= b / Z.gcd a b) by (apply Z.div_pos; auto with zarith). - Z.le_elim H; trivial. - rewrite (Zdivide_Zdiv_eq (Z.gcd a b) b), <- H, Z.mul_0_r in Hb; - auto using Z.gcd_divide_r with zarith. - Qed. - - Theorem Zdiv_neg a b: - a < 0 -> 0 < b -> a / b < 0. - Proof. - intros Ha Hb. - assert (b > 0) by omega. - generalize (Z_mult_div_ge a _ H); intros. - assert (b * (a / b) < 0)%Z. - apply Z.le_lt_trans with a; auto with zarith. - destruct b; try (compute in Hb; discriminate). - destruct (a/Zpos p)%Z. - compute in H1; discriminate. - compute in H1; discriminate. - compute; auto. - Qed. - - Lemma Zdiv_gcd_zero : forall a b, b / Z.gcd a b = 0 -> b <> 0 -> - Z.gcd a b = 0. - Proof. - intros. - generalize (Zgcd_is_gcd a b); destruct 1. - destruct H2 as (k,Hk). - generalize H; rewrite Hk at 1. - destruct (Z.eq_dec (Z.gcd a b) 0) as [H'|H']; auto. - rewrite Z_div_mult_full; auto. - intros; subst k; simpl in *; subst b; elim H0; auto. - Qed. - - Lemma Zgcd_mult_rel_prime : forall a b c, - Z.gcd a c = 1 -> Z.gcd b c = 1 -> Z.gcd (a*b) c = 1. - Proof. - intros. - rewrite Zgcd_1_rel_prime in *. - apply rel_prime_sym; apply rel_prime_mult; apply rel_prime_sym; auto. - Qed. - - Lemma Zcompare_gt : forall (A:Type)(a a':A)(p q:Z), - match (p?=q)%Z with Gt => a | _ => a' end = - if Z_le_gt_dec p q then a' else a. - Proof. - intros. - destruct Z_le_gt_dec as [H|H]. - red in H. - destruct (p?=q)%Z; auto; elim H; auto. - rewrite H; auto. - Qed. - -Theorem Zbounded_induction : - (forall Q : Z -> Prop, forall b : Z, - Q 0 -> - (forall n, 0 <= n -> n < b - 1 -> Q n -> Q (n + 1)) -> - forall n, 0 <= n -> n < b -> Q n)%Z. -Proof. -intros Q b Q0 QS. -set (Q' := fun n => (n < b /\ Q n) \/ (b <= n)). -assert (H : forall n, 0 <= n -> Q' n). -apply natlike_rec2; unfold Q'. -destruct (Z.le_gt_cases b 0) as [H | H]. now right. left; now split. -intros n H IH. destruct IH as [[IH1 IH2] | IH]. -destruct (Z.le_gt_cases (b - 1) n) as [H1 | H1]. -right; auto with zarith. -left. split; [auto with zarith | now apply (QS n)]. -right; auto with zarith. -unfold Q' in *; intros n H1 H2. destruct (H n H1) as [[H3 H4] | H3]. -assumption. now apply Z.le_ngt in H3. -Qed. - -Lemma Zsquare_le x : x <= x*x. -Proof. -destruct (Z.lt_ge_cases 0 x). -- rewrite <- Z.mul_1_l at 1. - rewrite <- Z.mul_le_mono_pos_r; auto with zarith. -- pose proof (Z.square_nonneg x); auto with zarith. -Qed. diff --git a/theories/Numbers/Cyclic/Abstract/CyclicAxioms.v b/theories/Numbers/Cyclic/Abstract/CyclicAxioms.v index 3312161ae1..8575801988 100644 --- a/theories/Numbers/Cyclic/Abstract/CyclicAxioms.v +++ b/theories/Numbers/Cyclic/Abstract/CyclicAxioms.v @@ -17,7 +17,7 @@ Set Implicit Arguments. Require Import ZArith. Require Import Znumtheory. -Require Import BigNumPrelude. +Require Import Zpow_facts. Require Import DoubleType. Local Open Scope Z_scope. diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleType.v b/theories/Numbers/Cyclic/Abstract/DoubleType.v index abd567a851..d60c19ea5d 100644 --- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleType.v +++ b/theories/Numbers/Cyclic/Abstract/DoubleType.v @@ -67,4 +67,3 @@ Fixpoint word (w:Type) (n:nat) : Type := | O => w | S n => zn2z (word w n) end. - diff --git a/theories/Numbers/Cyclic/Abstract/NZCyclic.v b/theories/Numbers/Cyclic/Abstract/NZCyclic.v index df9b833922..3f9b7b2971 100644 --- a/theories/Numbers/Cyclic/Abstract/NZCyclic.v +++ b/theories/Numbers/Cyclic/Abstract/NZCyclic.v @@ -9,7 +9,8 @@ (************************************************************************) Require Export NZAxioms. -Require Import BigNumPrelude. +Require Import ZArith. +Require Import Zpow_facts. Require Import DoubleType. Require Import CyclicAxioms. @@ -139,6 +140,26 @@ rewrite 2 ZnZ.of_Z_correct; auto with zarith. symmetry; apply Zmod_small; auto with zarith. Qed. +Theorem Zbounded_induction : + (forall Q : Z -> Prop, forall b : Z, + Q 0 -> + (forall n, 0 <= n -> n < b - 1 -> Q n -> Q (n + 1)) -> + forall n, 0 <= n -> n < b -> Q n)%Z. +Proof. +intros Q b Q0 QS. +set (Q' := fun n => (n < b /\ Q n) \/ (b <= n)). +assert (H : forall n, 0 <= n -> Q' n). +apply natlike_rec2; unfold Q'. +destruct (Z.le_gt_cases b 0) as [H | H]. now right. left; now split. +intros n H IH. destruct IH as [[IH1 IH2] | IH]. +destruct (Z.le_gt_cases (b - 1) n) as [H1 | H1]. +right; auto with zarith. +left. split; [auto with zarith | now apply (QS n)]. +right; auto with zarith. +unfold Q' in *; intros n H1 H2. destruct (H n H1) as [[H3 H4] | H3]. +assumption. now apply Z.le_ngt in H3. +Qed. + Lemma B_holds : forall n : Z, 0 <= n < wB -> B n. Proof. intros n [H1 H2]. diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleAdd.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleAdd.v deleted file mode 100644 index 407bcca4b6..0000000000 --- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleAdd.v +++ /dev/null @@ -1,317 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) -(* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) -(************************************************************************) - -Set Implicit Arguments. - -Require Import ZArith. -Require Import BigNumPrelude. -Require Import DoubleType. -Require Import DoubleBase. - -Local Open Scope Z_scope. - -Section DoubleAdd. - Variable w : Type. - Variable w_0 : w. - Variable w_1 : w. - Variable w_WW : w -> w -> zn2z w. - Variable w_W0 : w -> zn2z w. - Variable ww_1 : zn2z w. - Variable w_succ_c : w -> carry w. - Variable w_add_c : w -> w -> carry w. - Variable w_add_carry_c : w -> w -> carry w. - Variable w_succ : w -> w. - Variable w_add : w -> w -> w. - Variable w_add_carry : w -> w -> w. - - Definition ww_succ_c x := - match x with - | W0 => C0 ww_1 - | WW xh xl => - match w_succ_c xl with - | C0 l => C0 (WW xh l) - | C1 l => - match w_succ_c xh with - | C0 h => C0 (WW h w_0) - | C1 h => C1 W0 - end - end - end. - - Definition ww_succ x := - match x with - | W0 => ww_1 - | WW xh xl => - match w_succ_c xl with - | C0 l => WW xh l - | C1 l => w_W0 (w_succ xh) - end - end. - - Definition ww_add_c x y := - match x, y with - | W0, _ => C0 y - | _, W0 => C0 x - | WW xh xl, WW yh yl => - match w_add_c xl yl with - | C0 l => - match w_add_c xh yh with - | C0 h => C0 (WW h l) - | C1 h => C1 (w_WW h l) - end - | C1 l => - match w_add_carry_c xh yh with - | C0 h => C0 (WW h l) - | C1 h => C1 (w_WW h l) - end - end - end. - - Variable R : Type. - Variable f0 f1 : zn2z w -> R. - - Definition ww_add_c_cont x y := - match x, y with - | W0, _ => f0 y - | _, W0 => f0 x - | WW xh xl, WW yh yl => - match w_add_c xl yl with - | C0 l => - match w_add_c xh yh with - | C0 h => f0 (WW h l) - | C1 h => f1 (w_WW h l) - end - | C1 l => - match w_add_carry_c xh yh with - | C0 h => f0 (WW h l) - | C1 h => f1 (w_WW h l) - end - end - end. - - (* ww_add et ww_add_carry conserve la forme normale s'il n'y a pas - de debordement *) - Definition ww_add x y := - match x, y with - | W0, _ => y - | _, W0 => x - | WW xh xl, WW yh yl => - match w_add_c xl yl with - | C0 l => WW (w_add xh yh) l - | C1 l => WW (w_add_carry xh yh) l - end - end. - - Definition ww_add_carry_c x y := - match x, y with - | W0, W0 => C0 ww_1 - | W0, WW yh yl => ww_succ_c (WW yh yl) - | WW xh xl, W0 => ww_succ_c (WW xh xl) - | WW xh xl, WW yh yl => - match w_add_carry_c xl yl with - | C0 l => - match w_add_c xh yh with - | C0 h => C0 (WW h l) - | C1 h => C1 (WW h l) - end - | C1 l => - match w_add_carry_c xh yh with - | C0 h => C0 (WW h l) - | C1 h => C1 (w_WW h l) - end - end - end. - - Definition ww_add_carry x y := - match x, y with - | W0, W0 => ww_1 - | W0, WW yh yl => ww_succ (WW yh yl) - | WW xh xl, W0 => ww_succ (WW xh xl) - | WW xh xl, WW yh yl => - match w_add_carry_c xl yl with - | C0 l => WW (w_add xh yh) l - | C1 l => WW (w_add_carry xh yh) l - end - end. - - (*Section DoubleProof.*) - Variable w_digits : positive. - Variable w_to_Z : w -> Z. - - - Notation wB := (base w_digits). - Notation wwB := (base (ww_digits w_digits)). - Notation "[| x |]" := (w_to_Z x) (at level 0, x at level 99). - Notation "[+| c |]" := - (interp_carry 1 wB w_to_Z c) (at level 0, c at level 99). - Notation "[-| c |]" := - (interp_carry (-1) wB w_to_Z c) (at level 0, c at level 99). - - Notation "[[ x ]]" := (ww_to_Z w_digits w_to_Z x)(at level 0, x at level 99). - Notation "[+[ c ]]" := - (interp_carry 1 wwB (ww_to_Z w_digits w_to_Z) c) - (at level 0, c at level 99). - Notation "[-[ c ]]" := - (interp_carry (-1) wwB (ww_to_Z w_digits w_to_Z) c) - (at level 0, c at level 99). - - Variable spec_w_0 : [|w_0|] = 0. - Variable spec_w_1 : [|w_1|] = 1. - Variable spec_ww_1 : [[ww_1]] = 1. - Variable spec_to_Z : forall x, 0 <= [|x|] < wB. - Variable spec_w_WW : forall h l, [[w_WW h l]] = [|h|] * wB + [|l|]. - Variable spec_w_W0 : forall h, [[w_W0 h]] = [|h|] * wB. - Variable spec_w_succ_c : forall x, [+|w_succ_c x|] = [|x|] + 1. - Variable spec_w_add_c : forall x y, [+|w_add_c x y|] = [|x|] + [|y|]. - Variable spec_w_add_carry_c : - forall x y, [+|w_add_carry_c x y|] = [|x|] + [|y|] + 1. - Variable spec_w_succ : forall x, [|w_succ x|] = ([|x|] + 1) mod wB. - Variable spec_w_add : forall x y, [|w_add x y|] = ([|x|] + [|y|]) mod wB. - Variable spec_w_add_carry : - forall x y, [|w_add_carry x y|] = ([|x|] + [|y|] + 1) mod wB. - - Lemma spec_ww_succ_c : forall x, [+[ww_succ_c x]] = [[x]] + 1. - Proof. - destruct x as [ |xh xl];simpl. apply spec_ww_1. - generalize (spec_w_succ_c xl);destruct (w_succ_c xl) as [l|l]; - intro H;unfold interp_carry in H. simpl;rewrite H;ring. - rewrite <- Z.add_assoc;rewrite <- H;rewrite Z.mul_1_l. - assert ([|l|] = 0). generalize (spec_to_Z xl)(spec_to_Z l);omega. - rewrite H0;generalize (spec_w_succ_c xh);destruct (w_succ_c xh) as [h|h]; - intro H1;unfold interp_carry in H1. - simpl;rewrite H1;rewrite spec_w_0;ring. - unfold interp_carry;simpl ww_to_Z;rewrite wwB_wBwB. - assert ([|xh|] = wB - 1). generalize (spec_to_Z xh)(spec_to_Z h);omega. - rewrite H2;ring. - Qed. - - Lemma spec_ww_add_c : forall x y, [+[ww_add_c x y]] = [[x]] + [[y]]. - Proof. - destruct x as [ |xh xl];trivial. - destruct y as [ |yh yl]. rewrite Z.add_0_r;trivial. - simpl. replace ([|xh|] * wB + [|xl|] + ([|yh|] * wB + [|yl|])) - with (([|xh|]+[|yh|])*wB + ([|xl|]+[|yl|])). 2:ring. - generalize (spec_w_add_c xl yl);destruct (w_add_c xl yl) as [l|l]; - intros H;unfold interp_carry in H;rewrite <- H. - generalize (spec_w_add_c xh yh);destruct (w_add_c xh yh) as [h|h]; - intros H1;unfold interp_carry in *;rewrite <- H1. trivial. - repeat rewrite Z.mul_1_l;rewrite spec_w_WW;rewrite wwB_wBwB; ring. - rewrite Z.add_assoc;rewrite <- Z.mul_add_distr_r. - generalize (spec_w_add_carry_c xh yh);destruct (w_add_carry_c xh yh) - as [h|h]; intros H1;unfold interp_carry in *;rewrite <- H1. - simpl;ring. - repeat rewrite Z.mul_1_l;rewrite wwB_wBwB;rewrite spec_w_WW;ring. - Qed. - - Section Cont. - Variable P : zn2z w -> zn2z w -> R -> Prop. - Variable x y : zn2z w. - Variable spec_f0 : forall r, [[r]] = [[x]] + [[y]] -> P x y (f0 r). - Variable spec_f1 : forall r, wwB + [[r]] = [[x]] + [[y]] -> P x y (f1 r). - - Lemma spec_ww_add_c_cont : P x y (ww_add_c_cont x y). - Proof. - destruct x as [ |xh xl];trivial. - apply spec_f0;trivial. - destruct y as [ |yh yl]. - apply spec_f0;rewrite Z.add_0_r;trivial. - simpl. - generalize (spec_w_add_c xl yl);destruct (w_add_c xl yl) as [l|l]; - intros H;unfold interp_carry in H. - generalize (spec_w_add_c xh yh);destruct (w_add_c xh yh) as [h|h]; - intros H1;unfold interp_carry in *. - apply spec_f0. simpl;rewrite H;rewrite H1;ring. - apply spec_f1. simpl;rewrite spec_w_WW;rewrite H. - rewrite Z.add_assoc;rewrite wwB_wBwB. rewrite Z.pow_2_r; rewrite <- Z.mul_add_distr_r. - rewrite Z.mul_1_l in H1;rewrite H1;ring. - generalize (spec_w_add_carry_c xh yh);destruct (w_add_carry_c xh yh) - as [h|h]; intros H1;unfold interp_carry in *. - apply spec_f0;simpl;rewrite H1. rewrite Z.mul_add_distr_r. - rewrite <- Z.add_assoc;rewrite H;ring. - apply spec_f1. rewrite spec_w_WW;rewrite wwB_wBwB. - rewrite Z.add_assoc; rewrite Z.pow_2_r; rewrite <- Z.mul_add_distr_r. - rewrite Z.mul_1_l in H1;rewrite H1. rewrite Z.mul_add_distr_r. - rewrite <- Z.add_assoc;rewrite H; simpl; ring. - Qed. - - End Cont. - - Lemma spec_ww_add_carry_c : - forall x y, [+[ww_add_carry_c x y]] = [[x]] + [[y]] + 1. - Proof. - destruct x as [ |xh xl];intro y. - exact (spec_ww_succ_c y). - destruct y as [ |yh yl]. - rewrite Z.add_0_r;exact (spec_ww_succ_c (WW xh xl)). - simpl; replace ([|xh|] * wB + [|xl|] + ([|yh|] * wB + [|yl|]) + 1) - with (([|xh|]+[|yh|])*wB + ([|xl|]+[|yl|]+1)). 2:ring. - generalize (spec_w_add_carry_c xl yl);destruct (w_add_carry_c xl yl) - as [l|l];intros H;unfold interp_carry in H;rewrite <- H. - generalize (spec_w_add_c xh yh);destruct (w_add_c xh yh) as [h|h]; - intros H1;unfold interp_carry in H1;rewrite <- H1. trivial. - unfold interp_carry;repeat rewrite Z.mul_1_l;simpl;rewrite wwB_wBwB;ring. - rewrite Z.add_assoc;rewrite <- Z.mul_add_distr_r. - generalize (spec_w_add_carry_c xh yh);destruct (w_add_carry_c xh yh) - as [h|h];intros H1;unfold interp_carry in H1;rewrite <- H1. trivial. - unfold interp_carry;rewrite spec_w_WW; - repeat rewrite Z.mul_1_l;simpl;rewrite wwB_wBwB;ring. - Qed. - - Lemma spec_ww_succ : forall x, [[ww_succ x]] = ([[x]] + 1) mod wwB. - Proof. - destruct x as [ |xh xl];simpl. - rewrite spec_ww_1;rewrite Zmod_small;trivial. - split;[intro;discriminate|apply wwB_pos]. - rewrite <- Z.add_assoc;generalize (spec_w_succ_c xl); - destruct (w_succ_c xl) as[l|l];intro H;unfold interp_carry in H;rewrite <-H. - rewrite Zmod_small;trivial. - rewrite wwB_wBwB;apply beta_mult;apply spec_to_Z. - assert ([|l|] = 0). clear spec_ww_1 spec_w_1 spec_w_0. - assert (H1:= spec_to_Z l); assert (H2:= spec_to_Z xl); omega. - rewrite H0;rewrite Z.add_0_r;rewrite <- Z.mul_add_distr_r;rewrite wwB_wBwB. - rewrite Z.pow_2_r; rewrite Zmult_mod_distr_r;try apply lt_0_wB. - rewrite spec_w_W0;rewrite spec_w_succ;trivial. - Qed. - - Lemma spec_ww_add : forall x y, [[ww_add x y]] = ([[x]] + [[y]]) mod wwB. - Proof. - destruct x as [ |xh xl];intros y. - rewrite Zmod_small;trivial. apply spec_ww_to_Z;trivial. - destruct y as [ |yh yl]. - change [[W0]] with 0;rewrite Z.add_0_r. - rewrite Zmod_small;trivial. - exact (spec_ww_to_Z w_digits w_to_Z spec_to_Z (WW xh xl)). - simpl. replace ([|xh|] * wB + [|xl|] + ([|yh|] * wB + [|yl|])) - with (([|xh|]+[|yh|])*wB + ([|xl|]+[|yl|])). 2:ring. - generalize (spec_w_add_c xl yl);destruct (w_add_c xl yl) as [l|l]; - unfold interp_carry;intros H;simpl;rewrite <- H. - rewrite (mod_wwB w_digits w_to_Z spec_to_Z);rewrite spec_w_add;trivial. - rewrite Z.add_assoc;rewrite <- Z.mul_add_distr_r. - rewrite(mod_wwB w_digits w_to_Z spec_to_Z);rewrite spec_w_add_carry;trivial. - Qed. - - Lemma spec_ww_add_carry : - forall x y, [[ww_add_carry x y]] = ([[x]] + [[y]] + 1) mod wwB. - Proof. - destruct x as [ |xh xl];intros y. - exact (spec_ww_succ y). - destruct y as [ |yh yl]. - change [[W0]] with 0;rewrite Z.add_0_r. exact (spec_ww_succ (WW xh xl)). - simpl;replace ([|xh|] * wB + [|xl|] + ([|yh|] * wB + [|yl|]) + 1) - with (([|xh|]+[|yh|])*wB + ([|xl|]+[|yl|]+1)). 2:ring. - generalize (spec_w_add_carry_c xl yl);destruct (w_add_carry_c xl yl) - as [l|l];unfold interp_carry;intros H;rewrite <- H;simpl ww_to_Z. - rewrite(mod_wwB w_digits w_to_Z spec_to_Z);rewrite spec_w_add;trivial. - rewrite Z.add_assoc;rewrite <- Z.mul_add_distr_r. - rewrite(mod_wwB w_digits w_to_Z spec_to_Z);rewrite spec_w_add_carry;trivial. - Qed. - -(* End DoubleProof. *) -End DoubleAdd. diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleBase.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleBase.v deleted file mode 100644 index e94a891dd5..0000000000 --- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleBase.v +++ /dev/null @@ -1,437 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) -(* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) -(************************************************************************) - -Set Implicit Arguments. - -Require Import ZArith Ndigits. -Require Import BigNumPrelude. -Require Import DoubleType. - -Local Open Scope Z_scope. - -Local Infix "<<" := Pos.shiftl_nat (at level 30). - -Section DoubleBase. - Variable w : Type. - Variable w_0 : w. - Variable w_1 : w. - Variable w_Bm1 : w. - Variable w_WW : w -> w -> zn2z w. - Variable w_0W : w -> zn2z w. - Variable w_digits : positive. - Variable w_zdigits: w. - Variable w_add: w -> w -> zn2z w. - Variable w_to_Z : w -> Z. - Variable w_compare : w -> w -> comparison. - - Definition ww_digits := xO w_digits. - - Definition ww_zdigits := w_add w_zdigits w_zdigits. - - Definition ww_to_Z := zn2z_to_Z (base w_digits) w_to_Z. - - Definition ww_1 := WW w_0 w_1. - - Definition ww_Bm1 := WW w_Bm1 w_Bm1. - - Definition ww_WW xh xl : zn2z (zn2z w) := - match xh, xl with - | W0, W0 => W0 - | _, _ => WW xh xl - end. - - Definition ww_W0 h : zn2z (zn2z w) := - match h with - | W0 => W0 - | _ => WW h W0 - end. - - Definition ww_0W l : zn2z (zn2z w) := - match l with - | W0 => W0 - | _ => WW W0 l - end. - - Definition double_WW (n:nat) := - match n return word w n -> word w n -> word w (S n) with - | O => w_WW - | S n => - fun (h l : zn2z (word w n)) => - match h, l with - | W0, W0 => W0 - | _, _ => WW h l - end - end. - - Definition double_wB n := base (w_digits << n). - - Fixpoint double_to_Z (n:nat) : word w n -> Z := - match n return word w n -> Z with - | O => w_to_Z - | S n => zn2z_to_Z (double_wB n) (double_to_Z n) - end. - - Fixpoint extend_aux (n:nat) (x:zn2z w) {struct n}: word w (S n) := - match n return word w (S n) with - | O => x - | S n1 => WW W0 (extend_aux n1 x) - end. - - Definition extend (n:nat) (x:w) : word w (S n) := - let r := w_0W x in - match r with - | W0 => W0 - | _ => extend_aux n r - end. - - Definition double_0 n : word w n := - match n return word w n with - | O => w_0 - | S _ => W0 - end. - - Definition double_split (n:nat) (x:zn2z (word w n)) := - match x with - | W0 => - match n return word w n * word w n with - | O => (w_0,w_0) - | S _ => (W0, W0) - end - | WW h l => (h,l) - end. - - Definition ww_compare x y := - match x, y with - | W0, W0 => Eq - | W0, WW yh yl => - match w_compare w_0 yh with - | Eq => w_compare w_0 yl - | _ => Lt - end - | WW xh xl, W0 => - match w_compare xh w_0 with - | Eq => w_compare xl w_0 - | _ => Gt - end - | WW xh xl, WW yh yl => - match w_compare xh yh with - | Eq => w_compare xl yl - | Lt => Lt - | Gt => Gt - end - end. - - - (* Return the low part of the composed word*) - Fixpoint get_low (n : nat) {struct n}: - word w n -> w := - match n return (word w n -> w) with - | 0%nat => fun x => x - | S n1 => - fun x => - match x with - | W0 => w_0 - | WW _ x1 => get_low n1 x1 - end - end. - - - Section DoubleProof. - Notation wB := (base w_digits). - Notation wwB := (base ww_digits). - Notation "[| x |]" := (w_to_Z x) (at level 0, x at level 99). - Notation "[[ x ]]" := (ww_to_Z x) (at level 0, x at level 99). - Notation "[+[ c ]]" := - (interp_carry 1 wwB ww_to_Z c) (at level 0, c at level 99). - Notation "[-[ c ]]" := - (interp_carry (-1) wwB ww_to_Z c) (at level 0, c at level 99). - Notation "[! n | x !]" := (double_to_Z n x) (at level 0, x at level 99). - - Variable spec_w_0 : [|w_0|] = 0. - Variable spec_w_1 : [|w_1|] = 1. - Variable spec_w_Bm1 : [|w_Bm1|] = wB - 1. - Variable spec_w_WW : forall h l, [[w_WW h l]] = [|h|] * wB + [|l|]. - Variable spec_w_0W : forall l, [[w_0W l]] = [|l|]. - Variable spec_to_Z : forall x, 0 <= [|x|] < wB. - Variable spec_w_compare : forall x y, - w_compare x y = Z.compare [|x|] [|y|]. - - Lemma wwB_wBwB : wwB = wB^2. - Proof. - unfold base, ww_digits;rewrite Z.pow_2_r; rewrite (Pos2Z.inj_xO w_digits). - replace (2 * Zpos w_digits) with (Zpos w_digits + Zpos w_digits). - apply Zpower_exp; unfold Z.ge;simpl;intros;discriminate. - ring. - Qed. - - Lemma spec_ww_1 : [[ww_1]] = 1. - Proof. simpl;rewrite spec_w_0;rewrite spec_w_1;ring. Qed. - - Lemma spec_ww_Bm1 : [[ww_Bm1]] = wwB - 1. - Proof. simpl;rewrite spec_w_Bm1;rewrite wwB_wBwB;ring. Qed. - - Lemma lt_0_wB : 0 < wB. - Proof. - unfold base;apply Z.pow_pos_nonneg. unfold Z.lt;reflexivity. - unfold Z.le;intros H;discriminate H. - Qed. - - Lemma lt_0_wwB : 0 < wwB. - Proof. rewrite wwB_wBwB; rewrite Z.pow_2_r; apply Z.mul_pos_pos;apply lt_0_wB. Qed. - - Lemma wB_pos: 1 < wB. - Proof. - unfold base;apply Z.lt_le_trans with (2^1). unfold Z.lt;reflexivity. - apply Zpower_le_monotone. unfold Z.lt;reflexivity. - split;unfold Z.le;intros H. discriminate H. - clear spec_w_0W w_0W spec_w_Bm1 spec_to_Z spec_w_WW w_WW. - destruct w_digits; discriminate H. - Qed. - - Lemma wwB_pos: 1 < wwB. - Proof. - assert (H:= wB_pos);rewrite wwB_wBwB;rewrite <-(Z.mul_1_r 1). - rewrite Z.pow_2_r. - apply Zmult_lt_compat2;(split;[unfold Z.lt;reflexivity|trivial]). - apply Z.lt_le_incl;trivial. - Qed. - - Theorem wB_div_2: 2 * (wB / 2) = wB. - Proof. - clear spec_w_0 w_0 spec_w_1 w_1 spec_w_Bm1 w_Bm1 spec_w_WW spec_w_0W - spec_to_Z;unfold base. - assert (2 ^ Zpos w_digits = 2 * (2 ^ (Zpos w_digits - 1))). - pattern 2 at 2; rewrite <- Z.pow_1_r. - rewrite <- Zpower_exp; auto with zarith. - f_equal; auto with zarith. - case w_digits; compute; intros; discriminate. - rewrite H; f_equal; auto with zarith. - rewrite Z.mul_comm; apply Z_div_mult; auto with zarith. - Qed. - - Theorem wwB_div_2 : wwB / 2 = wB / 2 * wB. - Proof. - clear spec_w_0 w_0 spec_w_1 w_1 spec_w_Bm1 w_Bm1 spec_w_WW spec_w_0W - spec_to_Z. - rewrite wwB_wBwB; rewrite Z.pow_2_r. - pattern wB at 1; rewrite <- wB_div_2; auto. - rewrite <- Z.mul_assoc. - repeat (rewrite (Z.mul_comm 2); rewrite Z_div_mult); auto with zarith. - Qed. - - Lemma mod_wwB : forall z x, - (z*wB + [|x|]) mod wwB = (z mod wB)*wB + [|x|]. - Proof. - intros z x. - rewrite Zplus_mod. - pattern wwB at 1;rewrite wwB_wBwB; rewrite Z.pow_2_r. - rewrite Zmult_mod_distr_r;try apply lt_0_wB. - rewrite (Zmod_small [|x|]). - apply Zmod_small;rewrite wwB_wBwB;apply beta_mult;try apply spec_to_Z. - apply Z_mod_lt;apply Z.lt_gt;apply lt_0_wB. - destruct (spec_to_Z x);split;trivial. - change [|x|] with (0*wB+[|x|]). rewrite wwB_wBwB. - rewrite Z.pow_2_r;rewrite <- (Z.add_0_r (wB*wB));apply beta_lex_inv. - apply lt_0_wB. apply spec_to_Z. split;[apply Z.le_refl | apply lt_0_wB]. - Qed. - - Lemma wB_div : forall x y, ([|x|] * wB + [|y|]) / wB = [|x|]. - Proof. - clear spec_w_0 spec_w_1 spec_w_Bm1 w_0 w_1 w_Bm1. - intros x y;unfold base;rewrite Zdiv_shift_r;auto with zarith. - rewrite Z_div_mult;auto with zarith. - destruct (spec_to_Z x);trivial. - Qed. - - Lemma wB_div_plus : forall x y p, - 0 <= p -> - ([|x|]*wB + [|y|]) / 2^(Zpos w_digits + p) = [|x|] / 2^p. - Proof. - clear spec_w_0 spec_w_1 spec_w_Bm1 w_0 w_1 w_Bm1. - intros x y p Hp;rewrite Zpower_exp;auto with zarith. - rewrite <- Zdiv_Zdiv;auto with zarith. - rewrite wB_div;trivial. - Qed. - - Lemma lt_wB_wwB : wB < wwB. - Proof. - clear spec_w_0 spec_w_1 spec_w_Bm1 w_0 w_1 w_Bm1. - unfold base;apply Zpower_lt_monotone;auto with zarith. - assert (0 < Zpos w_digits). compute;reflexivity. - unfold ww_digits;rewrite Pos2Z.inj_xO;auto with zarith. - Qed. - - Lemma w_to_Z_wwB : forall x, x < wB -> x < wwB. - Proof. - intros x H;apply Z.lt_trans with wB;trivial;apply lt_wB_wwB. - Qed. - - Lemma spec_ww_to_Z : forall x, 0 <= [[x]] < wwB. - Proof. - clear spec_w_0 spec_w_1 spec_w_Bm1 w_0 w_1 w_Bm1. - destruct x as [ |h l];simpl. - split;[apply Z.le_refl|apply lt_0_wwB]. - assert (H:=spec_to_Z h);assert (L:=spec_to_Z l);split. - apply Z.add_nonneg_nonneg;auto with zarith. - rewrite <- (Z.add_0_r wwB);rewrite wwB_wBwB; rewrite Z.pow_2_r; - apply beta_lex_inv;auto with zarith. - Qed. - - Lemma double_wB_wwB : forall n, double_wB n * double_wB n = double_wB (S n). - Proof. - intros n;unfold double_wB;simpl. - unfold base. rewrite (Pos2Z.inj_xO (_ << _)). - replace (2 * Zpos (w_digits << n)) with - (Zpos (w_digits << n) + Zpos (w_digits << n)) by ring. - symmetry; apply Zpower_exp;intro;discriminate. - Qed. - - Lemma double_wB_pos: - forall n, 0 <= double_wB n. - Proof. - intros n; unfold double_wB, base; auto with zarith. - Qed. - - Lemma double_wB_more_digits: - forall n, wB <= double_wB n. - Proof. - clear spec_w_0 spec_w_1 spec_w_Bm1 w_0 w_1 w_Bm1. - intros n; elim n; clear n; auto. - unfold double_wB, "<<"; auto with zarith. - intros n H1; rewrite <- double_wB_wwB. - apply Z.le_trans with (wB * 1). - rewrite Z.mul_1_r; apply Z.le_refl. - unfold base; auto with zarith. - apply Z.mul_le_mono_nonneg; auto with zarith. - apply Z.le_trans with wB; auto with zarith. - unfold base. - rewrite <- (Z.pow_0_r 2). - apply Z.pow_le_mono_r; auto with zarith. - Qed. - - Lemma spec_double_to_Z : - forall n (x:word w n), 0 <= [!n | x!] < double_wB n. - Proof. - clear spec_w_0 spec_w_1 spec_w_Bm1 w_0 w_1 w_Bm1. - induction n;intros. exact (spec_to_Z x). - unfold double_to_Z;fold double_to_Z. - destruct x;unfold zn2z_to_Z. - unfold double_wB,base;split;auto with zarith. - assert (U0:= IHn w0);assert (U1:= IHn w1). - split;auto with zarith. - apply Z.lt_le_trans with ((double_wB n - 1) * double_wB n + double_wB n). - assert (double_to_Z n w0*double_wB n <= (double_wB n - 1)*double_wB n). - apply Z.mul_le_mono_nonneg_r;auto with zarith. - auto with zarith. - rewrite <- double_wB_wwB. - replace ((double_wB n - 1) * double_wB n + double_wB n) with (double_wB n * double_wB n); - [auto with zarith | ring]. - Qed. - - Lemma spec_get_low: - forall n x, - [!n | x!] < wB -> [|get_low n x|] = [!n | x!]. - Proof. - clear spec_w_1 spec_w_Bm1. - intros n; elim n; auto; clear n. - intros n Hrec x; case x; clear x; auto. - intros xx yy; simpl. - destruct (spec_double_to_Z n xx) as [F1 _]. Z.le_elim F1. - - (* 0 < [!n | xx!] *) - intros; exfalso. - assert (F3 := double_wB_more_digits n). - destruct (spec_double_to_Z n yy) as [F4 _]. - assert (F5: 1 * wB <= [!n | xx!] * double_wB n); - auto with zarith. - apply Z.mul_le_mono_nonneg; auto with zarith. - unfold base; auto with zarith. - - (* 0 = [!n | xx!] *) - rewrite <- F1; rewrite Z.mul_0_l, Z.add_0_l. - intros; apply Hrec; auto. - Qed. - - Lemma spec_double_WW : forall n (h l : word w n), - [!S n|double_WW n h l!] = [!n|h!] * double_wB n + [!n|l!]. - Proof. - induction n;simpl;intros;trivial. - destruct h;auto. - destruct l;auto. - Qed. - - Lemma spec_extend_aux : forall n x, [!S n|extend_aux n x!] = [[x]]. - Proof. induction n;simpl;trivial. Qed. - - Lemma spec_extend : forall n x, [!S n|extend n x!] = [|x|]. - Proof. - intros n x;assert (H:= spec_w_0W x);unfold extend. - destruct (w_0W x);simpl;trivial. - rewrite <- H;exact (spec_extend_aux n (WW w0 w1)). - Qed. - - Lemma spec_double_0 : forall n, [!n|double_0 n!] = 0. - Proof. destruct n;trivial. Qed. - - Lemma spec_double_split : forall n x, - let (h,l) := double_split n x in - [!S n|x!] = [!n|h!] * double_wB n + [!n|l!]. - Proof. - destruct x;simpl;auto. - destruct n;simpl;trivial. - rewrite spec_w_0;trivial. - Qed. - - Lemma wB_lex_inv: forall a b c d, - a < c -> - a * wB + [|b|] < c * wB + [|d|]. - Proof. - intros a b c d H1; apply beta_lex_inv with (1 := H1); auto. - Qed. - - Ltac comp2ord := match goal with - | |- Lt = (?x ?= ?y) => symmetry; change (x < y) - | |- Gt = (?x ?= ?y) => symmetry; change (x > y); apply Z.lt_gt - end. - - Lemma spec_ww_compare : forall x y, - ww_compare x y = Z.compare [[x]] [[y]]. - Proof. - destruct x as [ |xh xl];destruct y as [ |yh yl];simpl;trivial. - (* 1st case *) - rewrite 2 spec_w_compare, spec_w_0. - destruct (Z.compare_spec 0 [|yh|]) as [H|H|H]. - rewrite <- H;simpl. reflexivity. - symmetry. change (0 < [|yh|]*wB+[|yl|]). - change 0 with (0*wB+0). rewrite <- spec_w_0 at 2. - apply wB_lex_inv;trivial. - absurd (0 <= [|yh|]). apply Z.lt_nge; trivial. - destruct (spec_to_Z yh);trivial. - (* 2nd case *) - rewrite 2 spec_w_compare, spec_w_0. - destruct (Z.compare_spec [|xh|] 0) as [H|H|H]. - rewrite H;simpl;reflexivity. - absurd (0 <= [|xh|]). apply Z.lt_nge; trivial. - destruct (spec_to_Z xh);trivial. - comp2ord. - change 0 with (0*wB+0). rewrite <- spec_w_0 at 2. - apply wB_lex_inv;trivial. - (* 3rd case *) - rewrite 2 spec_w_compare. - destruct (Z.compare_spec [|xh|] [|yh|]) as [H|H|H]. - rewrite H. - symmetry. apply Z.add_compare_mono_l. - comp2ord. apply wB_lex_inv;trivial. - comp2ord. apply wB_lex_inv;trivial. - Qed. - - - End DoubleProof. - -End DoubleBase. - diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleCyclic.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleCyclic.v deleted file mode 100644 index 4ebe8fac1a..0000000000 --- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleCyclic.v +++ /dev/null @@ -1,966 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) -(* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) -(************************************************************************) - -Set Implicit Arguments. - -Require Import ZArith. -Require Import BigNumPrelude. -Require Import DoubleType. -Require Import DoubleBase. -Require Import DoubleAdd. -Require Import DoubleSub. -Require Import DoubleMul. -Require Import DoubleSqrt. -Require Import DoubleLift. -Require Import DoubleDivn1. -Require Import DoubleDiv. -Require Import CyclicAxioms. - -Local Open Scope Z_scope. - - -Section Z_2nZ. - - Context {t : Type}{ops : ZnZ.Ops t}. - - Let w_digits := ZnZ.digits. - Let w_zdigits := ZnZ.zdigits. - - Let w_to_Z := ZnZ.to_Z. - Let w_of_pos := ZnZ.of_pos. - Let w_head0 := ZnZ.head0. - Let w_tail0 := ZnZ.tail0. - - Let w_0 := ZnZ.zero. - Let w_1 := ZnZ.one. - Let w_Bm1 := ZnZ.minus_one. - - Let w_compare := ZnZ.compare. - Let w_eq0 := ZnZ.eq0. - - Let w_opp_c := ZnZ.opp_c. - Let w_opp := ZnZ.opp. - Let w_opp_carry := ZnZ.opp_carry. - - Let w_succ_c := ZnZ.succ_c. - Let w_add_c := ZnZ.add_c. - Let w_add_carry_c := ZnZ.add_carry_c. - Let w_succ := ZnZ.succ. - Let w_add := ZnZ.add. - Let w_add_carry := ZnZ.add_carry. - - Let w_pred_c := ZnZ.pred_c. - Let w_sub_c := ZnZ.sub_c. - Let w_sub_carry_c := ZnZ.sub_carry_c. - Let w_pred := ZnZ.pred. - Let w_sub := ZnZ.sub. - Let w_sub_carry := ZnZ.sub_carry. - - - Let w_mul_c := ZnZ.mul_c. - Let w_mul := ZnZ.mul. - Let w_square_c := ZnZ.square_c. - - Let w_div21 := ZnZ.div21. - Let w_div_gt := ZnZ.div_gt. - Let w_div := ZnZ.div. - - Let w_mod_gt := ZnZ.modulo_gt. - Let w_mod := ZnZ.modulo. - - Let w_gcd_gt := ZnZ.gcd_gt. - Let w_gcd := ZnZ.gcd. - - Let w_add_mul_div := ZnZ.add_mul_div. - - Let w_pos_mod := ZnZ.pos_mod. - - Let w_is_even := ZnZ.is_even. - Let w_sqrt2 := ZnZ.sqrt2. - Let w_sqrt := ZnZ.sqrt. - - Let _zn2z := zn2z t. - - Let wB := base w_digits. - - Let w_Bm2 := w_pred w_Bm1. - - Let ww_1 := ww_1 w_0 w_1. - Let ww_Bm1 := ww_Bm1 w_Bm1. - - Let w_add2 a b := match w_add_c a b with C0 p => WW w_0 p | C1 p => WW w_1 p end. - - Let _ww_digits := xO w_digits. - - Let _ww_zdigits := w_add2 w_zdigits w_zdigits. - - Let to_Z := zn2z_to_Z wB w_to_Z. - - Let w_W0 := ZnZ.WO. - Let w_0W := ZnZ.OW. - Let w_WW := ZnZ.WW. - - Let ww_of_pos p := - match w_of_pos p with - | (N0, l) => (N0, WW w_0 l) - | (Npos ph,l) => - let (n,h) := w_of_pos ph in (n, w_WW h l) - end. - - Let head0 := - Eval lazy beta delta [ww_head0] in - ww_head0 w_0 w_0W w_compare w_head0 w_add2 w_zdigits _ww_zdigits. - - Let tail0 := - Eval lazy beta delta [ww_tail0] in - ww_tail0 w_0 w_0W w_compare w_tail0 w_add2 w_zdigits _ww_zdigits. - - Let ww_WW := Eval lazy beta delta [ww_WW] in (@ww_WW t). - Let ww_0W := Eval lazy beta delta [ww_0W] in (@ww_0W t). - Let ww_W0 := Eval lazy beta delta [ww_W0] in (@ww_W0 t). - - (* ** Comparison ** *) - Let compare := - Eval lazy beta delta[ww_compare] in ww_compare w_0 w_compare. - - Let eq0 (x:zn2z t) := - match x with - | W0 => true - | _ => false - end. - - (* ** Opposites ** *) - Let opp_c := - Eval lazy beta delta [ww_opp_c] in ww_opp_c w_0 w_opp_c w_opp_carry. - - Let opp := - Eval lazy beta delta [ww_opp] in ww_opp w_0 w_opp_c w_opp_carry w_opp. - - Let opp_carry := - Eval lazy beta delta [ww_opp_carry] in ww_opp_carry w_WW ww_Bm1 w_opp_carry. - - (* ** Additions ** *) - - Let succ_c := - Eval lazy beta delta [ww_succ_c] in ww_succ_c w_0 ww_1 w_succ_c. - - Let add_c := - Eval lazy beta delta [ww_add_c] in ww_add_c w_WW w_add_c w_add_carry_c. - - Let add_carry_c := - Eval lazy beta iota delta [ww_add_carry_c ww_succ_c] in - ww_add_carry_c w_0 w_WW ww_1 w_succ_c w_add_c w_add_carry_c. - - Let succ := - Eval lazy beta delta [ww_succ] in ww_succ w_W0 ww_1 w_succ_c w_succ. - - Let add := - Eval lazy beta delta [ww_add] in ww_add w_add_c w_add w_add_carry. - - Let add_carry := - Eval lazy beta iota delta [ww_add_carry ww_succ] in - ww_add_carry w_W0 ww_1 w_succ_c w_add_carry_c w_succ w_add w_add_carry. - - (* ** Subtractions ** *) - - Let pred_c := - Eval lazy beta delta [ww_pred_c] in ww_pred_c w_Bm1 w_WW ww_Bm1 w_pred_c. - - Let sub_c := - Eval lazy beta iota delta [ww_sub_c ww_opp_c] in - ww_sub_c w_0 w_WW w_opp_c w_opp_carry w_sub_c w_sub_carry_c. - - Let sub_carry_c := - Eval lazy beta iota delta [ww_sub_carry_c ww_pred_c ww_opp_carry] in - ww_sub_carry_c w_Bm1 w_WW ww_Bm1 w_opp_carry w_pred_c w_sub_c w_sub_carry_c. - - Let pred := - Eval lazy beta delta [ww_pred] in ww_pred w_Bm1 w_WW ww_Bm1 w_pred_c w_pred. - - Let sub := - Eval lazy beta iota delta [ww_sub ww_opp] in - ww_sub w_0 w_WW w_opp_c w_opp_carry w_sub_c w_opp w_sub w_sub_carry. - - Let sub_carry := - Eval lazy beta iota delta [ww_sub_carry ww_pred ww_opp_carry] in - ww_sub_carry w_Bm1 w_WW ww_Bm1 w_opp_carry w_pred_c w_sub_carry_c w_pred - w_sub w_sub_carry. - - - (* ** Multiplication ** *) - - Let mul_c := - Eval lazy beta iota delta [ww_mul_c double_mul_c] in - ww_mul_c w_0 w_1 w_WW w_W0 w_mul_c add_c add add_carry. - - Let karatsuba_c := - Eval lazy beta iota delta [ww_karatsuba_c double_mul_c kara_prod] in - ww_karatsuba_c w_0 w_1 w_WW w_W0 w_compare w_add w_sub w_mul_c - add_c add add_carry sub_c sub. - - Let mul := - Eval lazy beta delta [ww_mul] in - ww_mul w_W0 w_add w_mul_c w_mul add. - - Let square_c := - Eval lazy beta delta [ww_square_c] in - ww_square_c w_0 w_1 w_WW w_W0 w_mul_c w_square_c add_c add add_carry. - - (* Division operation *) - - Let div32 := - Eval lazy beta iota delta [w_div32] in - w_div32 w_0 w_Bm1 w_Bm2 w_WW w_compare w_add_c w_add_carry_c - w_add w_add_carry w_pred w_sub w_mul_c w_div21 sub_c. - - Let div21 := - Eval lazy beta iota delta [ww_div21] in - ww_div21 w_0 w_0W div32 ww_1 compare sub. - - Let low (p: zn2z t) := match p with WW _ p1 => p1 | _ => w_0 end. - - Let add_mul_div := - Eval lazy beta delta [ww_add_mul_div] in - ww_add_mul_div w_0 w_WW w_W0 w_0W compare w_add_mul_div sub w_zdigits low. - - Let div_gt := - Eval lazy beta delta [ww_div_gt] in - ww_div_gt w_0 w_WW w_0W w_compare w_eq0 w_opp_c w_opp - w_opp_carry w_sub_c w_sub w_sub_carry - w_div_gt w_add_mul_div w_head0 w_div21 div32 _ww_zdigits ww_1 add_mul_div w_zdigits. - - Let div := - Eval lazy beta delta [ww_div] in ww_div ww_1 compare div_gt. - - Let mod_gt := - Eval lazy beta delta [ww_mod_gt] in - ww_mod_gt w_0 w_WW w_0W w_compare w_eq0 w_opp_c w_opp w_opp_carry w_sub_c w_sub w_sub_carry - w_mod_gt w_add_mul_div w_head0 w_div21 div32 _ww_zdigits add_mul_div w_zdigits. - - Let mod_ := - Eval lazy beta delta [ww_mod] in ww_mod compare mod_gt. - - Let pos_mod := - Eval lazy beta delta [ww_pos_mod] in - ww_pos_mod w_0 w_zdigits w_WW w_pos_mod compare w_0W low sub _ww_zdigits. - - Let is_even := - Eval lazy beta delta [ww_is_even] in ww_is_even w_is_even. - - Let sqrt2 := - Eval lazy beta delta [ww_sqrt2] in - ww_sqrt2 w_is_even w_compare w_0 w_1 w_Bm1 w_0W w_sub w_square_c - w_div21 w_add_mul_div w_zdigits w_add_c w_sqrt2 w_pred pred_c - pred add_c add sub_c add_mul_div. - - Let sqrt := - Eval lazy beta delta [ww_sqrt] in - ww_sqrt w_is_even w_0 w_sub w_add_mul_div w_zdigits - _ww_zdigits w_sqrt2 pred add_mul_div head0 compare low. - - Let gcd_gt_fix := - Eval cbv beta delta [ww_gcd_gt_aux ww_gcd_gt_body] in - ww_gcd_gt_aux w_0 w_WW w_0W w_compare w_opp_c w_opp w_opp_carry - w_sub_c w_sub w_sub_carry w_gcd_gt - w_add_mul_div w_head0 w_div21 div32 _ww_zdigits add_mul_div - w_zdigits. - - Let gcd_cont := - Eval lazy beta delta [gcd_cont] in gcd_cont ww_1 w_1 w_compare. - - Let gcd_gt := - Eval lazy beta delta [ww_gcd_gt] in - ww_gcd_gt w_0 w_eq0 w_gcd_gt _ww_digits gcd_gt_fix gcd_cont. - - Let gcd := - Eval lazy beta delta [ww_gcd] in - ww_gcd compare w_0 w_eq0 w_gcd_gt _ww_digits gcd_gt_fix gcd_cont. - - Definition lor (x y : zn2z t) := - match x, y with - | W0, _ => y - | _, W0 => x - | WW hx lx, WW hy ly => WW (ZnZ.lor hx hy) (ZnZ.lor lx ly) - end. - - Definition land (x y : zn2z t) := - match x, y with - | W0, _ => W0 - | _, W0 => W0 - | WW hx lx, WW hy ly => WW (ZnZ.land hx hy) (ZnZ.land lx ly) - end. - - Definition lxor (x y : zn2z t) := - match x, y with - | W0, _ => y - | _, W0 => x - | WW hx lx, WW hy ly => WW (ZnZ.lxor hx hy) (ZnZ.lxor lx ly) - end. - - (* ** Record of operators on 2 words *) - - Global Instance mk_zn2z_ops : ZnZ.Ops (zn2z t) | 1 := - ZnZ.MkOps _ww_digits _ww_zdigits - to_Z ww_of_pos head0 tail0 - W0 ww_1 ww_Bm1 - compare eq0 - opp_c opp opp_carry - succ_c add_c add_carry_c - succ add add_carry - pred_c sub_c sub_carry_c - pred sub sub_carry - mul_c mul square_c - div21 div_gt div - mod_gt mod_ - gcd_gt gcd - add_mul_div - pos_mod - is_even - sqrt2 - sqrt - lor - land - lxor. - - Global Instance mk_zn2z_ops_karatsuba : ZnZ.Ops (zn2z t) | 2 := - ZnZ.MkOps _ww_digits _ww_zdigits - to_Z ww_of_pos head0 tail0 - W0 ww_1 ww_Bm1 - compare eq0 - opp_c opp opp_carry - succ_c add_c add_carry_c - succ add add_carry - pred_c sub_c sub_carry_c - pred sub sub_carry - karatsuba_c mul square_c - div21 div_gt div - mod_gt mod_ - gcd_gt gcd - add_mul_div - pos_mod - is_even - sqrt2 - sqrt - lor - land - lxor. - - (* Proof *) - Context {specs : ZnZ.Specs ops}. - - Create HintDb ZnZ. - - Hint Resolve - ZnZ.spec_to_Z - ZnZ.spec_of_pos - ZnZ.spec_0 - ZnZ.spec_1 - ZnZ.spec_m1 - ZnZ.spec_compare - ZnZ.spec_eq0 - ZnZ.spec_opp_c - ZnZ.spec_opp - ZnZ.spec_opp_carry - ZnZ.spec_succ_c - ZnZ.spec_add_c - ZnZ.spec_add_carry_c - ZnZ.spec_succ - ZnZ.spec_add - ZnZ.spec_add_carry - ZnZ.spec_pred_c - ZnZ.spec_sub_c - ZnZ.spec_sub_carry_c - ZnZ.spec_pred - ZnZ.spec_sub - ZnZ.spec_sub_carry - ZnZ.spec_mul_c - ZnZ.spec_mul - ZnZ.spec_square_c - ZnZ.spec_div21 - ZnZ.spec_div_gt - ZnZ.spec_div - ZnZ.spec_modulo_gt - ZnZ.spec_modulo - ZnZ.spec_gcd_gt - ZnZ.spec_gcd - ZnZ.spec_head0 - ZnZ.spec_tail0 - ZnZ.spec_add_mul_div - ZnZ.spec_pos_mod - ZnZ.spec_is_even - ZnZ.spec_sqrt2 - ZnZ.spec_sqrt - ZnZ.spec_WO - ZnZ.spec_OW - ZnZ.spec_WW : ZnZ. - - Ltac wwauto := unfold ww_to_Z; eauto with ZnZ. - - Let wwB := base _ww_digits. - - Notation "[| x |]" := (to_Z x) (at level 0, x at level 99). - - Notation "[+| c |]" := - (interp_carry 1 wwB to_Z c) (at level 0, c at level 99). - - Notation "[-| c |]" := - (interp_carry (-1) wwB to_Z c) (at level 0, c at level 99). - - Notation "[[ x ]]" := (zn2z_to_Z wwB to_Z x) (at level 0, x at level 99). - - Let spec_ww_to_Z : forall x, 0 <= [| x |] < wwB. - Proof. refine (spec_ww_to_Z w_digits w_to_Z _); wwauto. Qed. - - Let spec_ww_of_pos : forall p, - Zpos p = (Z.of_N (fst (ww_of_pos p)))*wwB + [|(snd (ww_of_pos p))|]. - Proof. - unfold ww_of_pos;intros. - rewrite (ZnZ.spec_of_pos p). unfold w_of_pos. - case (ZnZ.of_pos p); intros. simpl. - destruct n; simpl ZnZ.to_Z. - simpl;unfold w_to_Z,w_0; rewrite ZnZ.spec_0;trivial. - unfold Z.of_N. - rewrite (ZnZ.spec_of_pos p0). - case (ZnZ.of_pos p0); intros. simpl. - unfold fst, snd,Z.of_N, to_Z, wB, w_digits, w_to_Z, w_WW. - rewrite ZnZ.spec_WW. - replace wwB with (wB*wB). - unfold wB,w_to_Z,w_digits;destruct n;ring. - symmetry. rewrite <- Z.pow_2_r; exact (wwB_wBwB w_digits). - Qed. - - Let spec_ww_0 : [|W0|] = 0. - Proof. reflexivity. Qed. - - Let spec_ww_1 : [|ww_1|] = 1. - Proof. refine (spec_ww_1 w_0 w_1 w_digits w_to_Z _ _);wwauto. Qed. - - Let spec_ww_Bm1 : [|ww_Bm1|] = wwB - 1. - Proof. refine (spec_ww_Bm1 w_Bm1 w_digits w_to_Z _);wwauto. Qed. - - Let spec_ww_compare : - forall x y, compare x y = Z.compare [|x|] [|y|]. - Proof. - refine (spec_ww_compare w_0 w_digits w_to_Z w_compare _ _ _);wwauto. - Qed. - - Let spec_ww_eq0 : forall x, eq0 x = true -> [|x|] = 0. - Proof. destruct x;simpl;intros;trivial;discriminate. Qed. - - Let spec_ww_opp_c : forall x, [-|opp_c x|] = -[|x|]. - Proof. - refine(spec_ww_opp_c w_0 w_0 W0 w_opp_c w_opp_carry w_digits w_to_Z _ _ _ _); - wwauto. - Qed. - - Let spec_ww_opp : forall x, [|opp x|] = (-[|x|]) mod wwB. - Proof. - refine(spec_ww_opp w_0 w_0 W0 w_opp_c w_opp_carry w_opp - w_digits w_to_Z _ _ _ _ _); - wwauto. - Qed. - - Let spec_ww_opp_carry : forall x, [|opp_carry x|] = wwB - [|x|] - 1. - Proof. - refine (spec_ww_opp_carry w_WW ww_Bm1 w_opp_carry w_digits w_to_Z _ _ _); - wwauto. - Qed. - - Let spec_ww_succ_c : forall x, [+|succ_c x|] = [|x|] + 1. - Proof. - refine (spec_ww_succ_c w_0 w_0 ww_1 w_succ_c w_digits w_to_Z _ _ _ _);wwauto. - Qed. - - Let spec_ww_add_c : forall x y, [+|add_c x y|] = [|x|] + [|y|]. - Proof. - refine (spec_ww_add_c w_WW w_add_c w_add_carry_c w_digits w_to_Z _ _ _);wwauto. - Qed. - - Let spec_ww_add_carry_c : forall x y, [+|add_carry_c x y|] = [|x|]+[|y|]+1. - Proof. - refine (spec_ww_add_carry_c w_0 w_0 w_WW ww_1 w_succ_c w_add_c w_add_carry_c - w_digits w_to_Z _ _ _ _ _ _ _);wwauto. - Qed. - - Let spec_ww_succ : forall x, [|succ x|] = ([|x|] + 1) mod wwB. - Proof. - refine (spec_ww_succ w_W0 ww_1 w_succ_c w_succ w_digits w_to_Z _ _ _ _ _); - wwauto. - Qed. - - Let spec_ww_add : forall x y, [|add x y|] = ([|x|] + [|y|]) mod wwB. - Proof. - refine (spec_ww_add w_add_c w_add w_add_carry w_digits w_to_Z _ _ _ _);wwauto. - Qed. - - Let spec_ww_add_carry : forall x y, [|add_carry x y|]=([|x|]+[|y|]+1)mod wwB. - Proof. - refine (spec_ww_add_carry w_W0 ww_1 w_succ_c w_add_carry_c w_succ - w_add w_add_carry w_digits w_to_Z _ _ _ _ _ _ _ _);wwauto. - Qed. - - Let spec_ww_pred_c : forall x, [-|pred_c x|] = [|x|] - 1. - Proof. - refine (spec_ww_pred_c w_0 w_Bm1 w_WW ww_Bm1 w_pred_c w_digits w_to_Z - _ _ _ _ _);wwauto. - Qed. - - Let spec_ww_sub_c : forall x y, [-|sub_c x y|] = [|x|] - [|y|]. - Proof. - refine (spec_ww_sub_c w_0 w_0 w_WW W0 w_opp_c w_opp_carry w_sub_c - w_sub_carry_c w_digits w_to_Z _ _ _ _ _ _ _);wwauto. - Qed. - - Let spec_ww_sub_carry_c : forall x y, [-|sub_carry_c x y|] = [|x|]-[|y|]-1. - Proof. - refine (spec_ww_sub_carry_c w_0 w_Bm1 w_WW ww_Bm1 w_opp_carry w_pred_c - w_sub_c w_sub_carry_c w_digits w_to_Z _ _ _ _ _ _ _ _);wwauto. - Qed. - - Let spec_ww_pred : forall x, [|pred x|] = ([|x|] - 1) mod wwB. - Proof. - refine (spec_ww_pred w_0 w_Bm1 w_WW ww_Bm1 w_pred_c w_pred w_digits w_to_Z - _ _ _ _ _ _);wwauto. - Qed. - - Let spec_ww_sub : forall x y, [|sub x y|] = ([|x|] - [|y|]) mod wwB. - Proof. - refine (spec_ww_sub w_0 w_0 w_WW W0 w_opp_c w_opp_carry w_sub_c w_opp - w_sub w_sub_carry w_digits w_to_Z _ _ _ _ _ _ _ _ _);wwauto. - Qed. - - Let spec_ww_sub_carry : forall x y, [|sub_carry x y|]=([|x|]-[|y|]-1) mod wwB. - Proof. - refine (spec_ww_sub_carry w_0 w_Bm1 w_WW ww_Bm1 w_opp_carry w_pred_c - w_sub_carry_c w_pred w_sub w_sub_carry w_digits w_to_Z _ _ _ _ _ _ _ _ _ _); - wwauto. - Qed. - - Let spec_ww_mul_c : forall x y, [[mul_c x y ]] = [|x|] * [|y|]. - Proof. - refine (spec_ww_mul_c w_0 w_1 w_WW w_W0 w_mul_c add_c add add_carry w_digits - w_to_Z _ _ _ _ _ _ _ _ _);wwauto. - Qed. - - Let spec_ww_karatsuba_c : forall x y, [[karatsuba_c x y ]] = [|x|] * [|y|]. - Proof. - refine (spec_ww_karatsuba_c _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ - _ _ _ _ _ _ _ _ _ _ _ _); wwauto. - unfold w_digits; apply ZnZ.spec_more_than_1_digit; auto. - Qed. - - Let spec_ww_mul : forall x y, [|mul x y|] = ([|x|] * [|y|]) mod wwB. - Proof. - refine (spec_ww_mul w_W0 w_add w_mul_c w_mul add w_digits w_to_Z _ _ _ _ _); - wwauto. - Qed. - - Let spec_ww_square_c : forall x, [[square_c x]] = [|x|] * [|x|]. - Proof. - refine (spec_ww_square_c w_0 w_1 w_WW w_W0 w_mul_c w_square_c add_c add - add_carry w_digits w_to_Z _ _ _ _ _ _ _ _ _ _);wwauto. - Qed. - - Let spec_w_div32 : forall a1 a2 a3 b1 b2, - wB / 2 <= (w_to_Z b1) -> - [|WW a1 a2|] < [|WW b1 b2|] -> - let (q, r) := div32 a1 a2 a3 b1 b2 in - (w_to_Z a1) * wwB + (w_to_Z a2) * wB + (w_to_Z a3) = - (w_to_Z q) * ((w_to_Z b1)*wB + (w_to_Z b2)) + [|r|] /\ - 0 <= [|r|] < (w_to_Z b1)*wB + w_to_Z b2. - Proof. - refine (spec_w_div32 w_0 w_Bm1 w_Bm2 w_WW w_compare w_add_c w_add_carry_c - w_add w_add_carry w_pred w_sub w_mul_c w_div21 sub_c w_digits w_to_Z - _ _ _ _ _ _ _ _ _ _ _ _ _ _ _);wwauto. - unfold w_Bm2, w_to_Z, w_pred, w_Bm1. - rewrite ZnZ.spec_pred, ZnZ.spec_m1. - unfold w_digits;rewrite Zmod_small. ring. - assert (H:= wB_pos(ZnZ.digits)). omega. - exact ZnZ.spec_div21. - Qed. - - Let spec_ww_div21 : forall a1 a2 b, - wwB/2 <= [|b|] -> - [|a1|] < [|b|] -> - let (q,r) := div21 a1 a2 b in - [|a1|] *wwB+ [|a2|] = [|q|] * [|b|] + [|r|] /\ - 0 <= [|r|] < [|b|]. - Proof. - refine (spec_ww_div21 w_0 w_0W div32 ww_1 compare sub w_digits w_to_Z - _ _ _ _ _ _ _);wwauto. - Qed. - - Let spec_add2: forall x y, - [|w_add2 x y|] = w_to_Z x + w_to_Z y. - unfold w_add2. - intros xh xl; generalize (ZnZ.spec_add_c xh xl). - unfold w_add_c; case ZnZ.add_c; unfold interp_carry; simpl ww_to_Z. - intros w0 Hw0; simpl; unfold w_to_Z; rewrite Hw0. - unfold w_0; rewrite ZnZ.spec_0; simpl; auto with zarith. - intros w0; rewrite Z.mul_1_l; simpl. - unfold w_to_Z, w_1; rewrite ZnZ.spec_1; auto with zarith. - rewrite Z.mul_1_l; auto. - Qed. - - Let spec_low: forall x, - w_to_Z (low x) = [|x|] mod wB. - intros x; case x; simpl low. - unfold ww_to_Z, w_to_Z, w_0; rewrite ZnZ.spec_0; simpl; wwauto. - intros xh xl; simpl. - rewrite Z.add_comm; rewrite Z_mod_plus; auto with zarith. - rewrite Zmod_small; auto with zarith. - unfold wB, base; eauto with ZnZ zarith. - unfold wB, base; eauto with ZnZ zarith. - Qed. - - Let spec_ww_digits: - [|_ww_zdigits|] = Zpos (xO w_digits). - Proof. - unfold w_to_Z, _ww_zdigits. - rewrite spec_add2. - unfold w_to_Z, w_zdigits, w_digits. - rewrite ZnZ.spec_zdigits; auto. - rewrite Pos2Z.inj_xO; auto with zarith. - Qed. - - - Let spec_ww_head00 : forall x, [|x|] = 0 -> [|head0 x|] = Zpos _ww_digits. - Proof. - refine (spec_ww_head00 w_0 w_0W - w_compare w_head0 w_add2 w_zdigits _ww_zdigits - w_to_Z _ _ _ (eq_refl _ww_digits) _ _ _ _); wwauto. - exact ZnZ.spec_head00. - exact ZnZ.spec_zdigits. - Qed. - - Let spec_ww_head0 : forall x, 0 < [|x|] -> - wwB/ 2 <= 2 ^ [|head0 x|] * [|x|] < wwB. - Proof. - refine (spec_ww_head0 w_0 w_0W w_compare w_head0 - w_add2 w_zdigits _ww_zdigits - w_to_Z _ _ _ _ _ _ _);wwauto. - exact ZnZ.spec_zdigits. - Qed. - - Let spec_ww_tail00 : forall x, [|x|] = 0 -> [|tail0 x|] = Zpos _ww_digits. - Proof. - refine (spec_ww_tail00 w_0 w_0W - w_compare w_tail0 w_add2 w_zdigits _ww_zdigits - w_to_Z _ _ _ (eq_refl _ww_digits) _ _ _ _); wwauto. - exact ZnZ.spec_tail00. - exact ZnZ.spec_zdigits. - Qed. - - - Let spec_ww_tail0 : forall x, 0 < [|x|] -> - exists y, 0 <= y /\ [|x|] = (2 * y + 1) * 2 ^ [|tail0 x|]. - Proof. - refine (spec_ww_tail0 (w_digits := w_digits) w_0 w_0W w_compare w_tail0 - w_add2 w_zdigits _ww_zdigits w_to_Z _ _ _ _ _ _ _);wwauto. - exact ZnZ.spec_zdigits. - Qed. - - Lemma spec_ww_add_mul_div : forall x y p, - [|p|] <= Zpos _ww_digits -> - [| add_mul_div p x y |] = - ([|x|] * (2 ^ [|p|]) + - [|y|] / (2 ^ ((Zpos _ww_digits) - [|p|]))) mod wwB. - Proof. - refine (@spec_ww_add_mul_div t w_0 w_WW w_W0 w_0W compare w_add_mul_div - sub w_digits w_zdigits low w_to_Z - _ _ _ _ _ _ _ _ _ _ _);wwauto. - exact ZnZ.spec_zdigits. - Qed. - - Let spec_ww_div_gt : forall a b, - [|a|] > [|b|] -> 0 < [|b|] -> - let (q,r) := div_gt a b in - [|a|] = [|q|] * [|b|] + [|r|] /\ 0 <= [|r|] < [|b|]. - Proof. -refine -(@spec_ww_div_gt t w_digits w_0 w_WW w_0W w_compare w_eq0 - w_opp_c w_opp w_opp_carry w_sub_c w_sub w_sub_carry w_div_gt - w_add_mul_div w_head0 w_div21 div32 _ww_zdigits ww_1 add_mul_div w_zdigits w_to_Z - _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ -). - exact ZnZ.spec_0. - exact ZnZ.spec_to_Z. - wwauto. - wwauto. - exact ZnZ.spec_compare. - exact ZnZ.spec_eq0. - exact ZnZ.spec_opp_c. - exact ZnZ.spec_opp. - exact ZnZ.spec_opp_carry. - exact ZnZ.spec_sub_c. - exact ZnZ.spec_sub. - exact ZnZ.spec_sub_carry. - exact ZnZ.spec_div_gt. - exact ZnZ.spec_add_mul_div. - exact ZnZ.spec_head0. - exact ZnZ.spec_div21. - exact spec_w_div32. - exact ZnZ.spec_zdigits. - exact spec_ww_digits. - exact spec_ww_1. - exact spec_ww_add_mul_div. - Qed. - - Let spec_ww_div : forall a b, 0 < [|b|] -> - let (q,r) := div a b in - [|a|] = [|q|] * [|b|] + [|r|] /\ - 0 <= [|r|] < [|b|]. - Proof. - refine (spec_ww_div w_digits ww_1 compare div_gt w_to_Z _ _ _ _);wwauto. - Qed. - - Let spec_ww_mod_gt : forall a b, - [|a|] > [|b|] -> 0 < [|b|] -> - [|mod_gt a b|] = [|a|] mod [|b|]. - Proof. - refine (@spec_ww_mod_gt t w_digits w_0 w_WW w_0W w_compare w_eq0 - w_opp_c w_opp w_opp_carry w_sub_c w_sub w_sub_carry w_div_gt w_mod_gt - w_add_mul_div w_head0 w_div21 div32 _ww_zdigits ww_1 add_mul_div - w_zdigits w_to_Z - _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _);wwauto. - exact ZnZ.spec_div_gt. - exact ZnZ.spec_div21. - exact ZnZ.spec_zdigits. - exact spec_ww_add_mul_div. - Qed. - - Let spec_ww_mod : forall a b, 0 < [|b|] -> [|mod_ a b|] = [|a|] mod [|b|]. - Proof. - refine (spec_ww_mod w_digits W0 compare mod_gt w_to_Z _ _ _);wwauto. - Qed. - - Let spec_ww_gcd_gt : forall a b, [|a|] > [|b|] -> - Zis_gcd [|a|] [|b|] [|gcd_gt a b|]. - Proof. - refine (@spec_ww_gcd_gt t w_digits W0 w_to_Z _ - w_0 w_0 w_eq0 w_gcd_gt _ww_digits - _ gcd_gt_fix _ _ _ _ gcd_cont _);wwauto. - refine (@spec_ww_gcd_gt_aux t w_digits w_0 w_WW w_0W w_compare w_opp_c w_opp - w_opp_carry w_sub_c w_sub w_sub_carry w_gcd_gt w_add_mul_div w_head0 - w_div21 div32 _ww_zdigits ww_1 add_mul_div w_zdigits w_to_Z - _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _);wwauto. - exact ZnZ.spec_div21. - exact ZnZ.spec_zdigits. - exact spec_ww_add_mul_div. - refine (@spec_gcd_cont t w_digits ww_1 w_to_Z _ _ w_0 w_1 w_compare - _ _);wwauto. - Qed. - - Let spec_ww_gcd : forall a b, Zis_gcd [|a|] [|b|] [|gcd a b|]. - Proof. - refine (@spec_ww_gcd t w_digits W0 compare w_to_Z _ _ w_0 w_0 w_eq0 w_gcd_gt - _ww_digits _ gcd_gt_fix _ _ _ _ gcd_cont _);wwauto. - refine (@spec_ww_gcd_gt_aux t w_digits w_0 w_WW w_0W w_compare w_opp_c w_opp - w_opp_carry w_sub_c w_sub w_sub_carry w_gcd_gt w_add_mul_div w_head0 - w_div21 div32 _ww_zdigits ww_1 add_mul_div w_zdigits w_to_Z - _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _);wwauto. - exact ZnZ.spec_div21. - exact ZnZ.spec_zdigits. - exact spec_ww_add_mul_div. - refine (@spec_gcd_cont t w_digits ww_1 w_to_Z _ _ w_0 w_1 w_compare - _ _);wwauto. - Qed. - - Let spec_ww_is_even : forall x, - match is_even x with - true => [|x|] mod 2 = 0 - | false => [|x|] mod 2 = 1 - end. - Proof. - refine (@spec_ww_is_even t w_is_even w_digits _ _ ). - exact ZnZ.spec_is_even. - Qed. - - Let spec_ww_sqrt2 : forall x y, - wwB/ 4 <= [|x|] -> - let (s,r) := sqrt2 x y in - [[WW x y]] = [|s|] ^ 2 + [+|r|] /\ - [+|r|] <= 2 * [|s|]. - Proof. - intros x y H. - refine (@spec_ww_sqrt2 t w_is_even w_compare w_0 w_1 w_Bm1 - w_0W w_sub w_square_c w_div21 w_add_mul_div w_digits w_zdigits - _ww_zdigits - w_add_c w_sqrt2 w_pred pred_c pred add_c add sub_c add_mul_div - _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _); wwauto. - exact ZnZ.spec_zdigits. - exact ZnZ.spec_more_than_1_digit. - exact ZnZ.spec_is_even. - exact ZnZ.spec_div21. - exact spec_ww_add_mul_div. - exact ZnZ.spec_sqrt2. - Qed. - - Let spec_ww_sqrt : forall x, - [|sqrt x|] ^ 2 <= [|x|] < ([|sqrt x|] + 1) ^ 2. - Proof. - refine (@spec_ww_sqrt t w_is_even w_0 w_1 w_Bm1 - w_sub w_add_mul_div w_digits w_zdigits _ww_zdigits - w_sqrt2 pred add_mul_div head0 compare - _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _); wwauto. - exact ZnZ.spec_zdigits. - exact ZnZ.spec_more_than_1_digit. - exact ZnZ.spec_is_even. - exact spec_ww_add_mul_div. - exact ZnZ.spec_sqrt2. - Qed. - - Let wB_pos : 0 < wB. - Proof. - unfold wB, base; apply Z.pow_pos_nonneg; auto with zarith. - Qed. - - Hint Transparent ww_to_Z. - - Let ww_testbit_high n x y : Z.pos w_digits <= n -> - Z.testbit [|WW x y|] n = - Z.testbit (ZnZ.to_Z x) (n - Z.pos w_digits). - Proof. - intros Hn. - assert (E : ZnZ.to_Z x = [|WW x y|] / wB). - { simpl. - rewrite Z.div_add_l; eauto with ZnZ zarith. - now rewrite Z.div_small, Z.add_0_r; wwauto. } - rewrite E. - unfold wB, base. rewrite Z.div_pow2_bits. - - f_equal; auto with zarith. - - easy. - - auto with zarith. - Qed. - - Let ww_testbit_low n x y : 0 <= n < Z.pos w_digits -> - Z.testbit [|WW x y|] n = Z.testbit (ZnZ.to_Z y) n. - Proof. - intros (Hn,Hn'). - assert (E : ZnZ.to_Z y = [|WW x y|] mod wB). - { simpl; symmetry. - rewrite Z.add_comm, Z.mod_add; auto with zarith nocore. - apply Z.mod_small; eauto with ZnZ zarith. } - rewrite E. - unfold wB, base. symmetry. apply Z.mod_pow2_bits_low; auto. - Qed. - - Let spec_lor x y : [|lor x y|] = Z.lor [|x|] [|y|]. - Proof. - destruct x as [ |hx lx]. trivial. - destruct y as [ |hy ly]. now rewrite Z.lor_comm. - change ([|WW (ZnZ.lor hx hy) (ZnZ.lor lx ly)|] = - Z.lor [|WW hx lx|] [|WW hy ly|]). - apply Z.bits_inj'; intros n Hn. - rewrite Z.lor_spec. - destruct (Z.le_gt_cases (Z.pos w_digits) n) as [LE|GT]. - - now rewrite !ww_testbit_high, ZnZ.spec_lor, Z.lor_spec. - - rewrite !ww_testbit_low; auto. - now rewrite ZnZ.spec_lor, Z.lor_spec. - Qed. - - Let spec_land x y : [|land x y|] = Z.land [|x|] [|y|]. - Proof. - destruct x as [ |hx lx]. trivial. - destruct y as [ |hy ly]. now rewrite Z.land_comm. - change ([|WW (ZnZ.land hx hy) (ZnZ.land lx ly)|] = - Z.land [|WW hx lx|] [|WW hy ly|]). - apply Z.bits_inj'; intros n Hn. - rewrite Z.land_spec. - destruct (Z.le_gt_cases (Z.pos w_digits) n) as [LE|GT]. - - now rewrite !ww_testbit_high, ZnZ.spec_land, Z.land_spec. - - rewrite !ww_testbit_low; auto. - now rewrite ZnZ.spec_land, Z.land_spec. - Qed. - - Let spec_lxor x y : [|lxor x y|] = Z.lxor [|x|] [|y|]. - Proof. - destruct x as [ |hx lx]. trivial. - destruct y as [ |hy ly]. now rewrite Z.lxor_comm. - change ([|WW (ZnZ.lxor hx hy) (ZnZ.lxor lx ly)|] = - Z.lxor [|WW hx lx|] [|WW hy ly|]). - apply Z.bits_inj'; intros n Hn. - rewrite Z.lxor_spec. - destruct (Z.le_gt_cases (Z.pos w_digits) n) as [LE|GT]. - - now rewrite !ww_testbit_high, ZnZ.spec_lxor, Z.lxor_spec. - - rewrite !ww_testbit_low; auto. - now rewrite ZnZ.spec_lxor, Z.lxor_spec. - Qed. - - Global Instance mk_zn2z_specs : ZnZ.Specs mk_zn2z_ops. - Proof. - apply ZnZ.MkSpecs; auto. - exact spec_ww_add_mul_div. - - refine (@spec_ww_pos_mod t w_0 w_digits w_zdigits w_WW - w_pos_mod compare w_0W low sub _ww_zdigits w_to_Z - _ _ _ _ _ _ _ _ _ _ _ _);wwauto. - exact ZnZ.spec_zdigits. - unfold w_to_Z, w_zdigits. - rewrite ZnZ.spec_zdigits. - rewrite <- Pos2Z.inj_xO; exact spec_ww_digits. - Qed. - - Global Instance mk_zn2z_specs_karatsuba : ZnZ.Specs mk_zn2z_ops_karatsuba. - Proof. - apply ZnZ.MkSpecs; auto. - exact spec_ww_add_mul_div. - refine (@spec_ww_pos_mod t w_0 w_digits w_zdigits w_WW - w_pos_mod compare w_0W low sub _ww_zdigits w_to_Z - _ _ _ _ _ _ _ _ _ _ _ _);wwauto. - exact ZnZ.spec_zdigits. - unfold w_to_Z, w_zdigits. - rewrite ZnZ.spec_zdigits. - rewrite <- Pos2Z.inj_xO; exact spec_ww_digits. - Qed. - -End Z_2nZ. - - -Section MulAdd. - - Context {t : Type}{ops : ZnZ.Ops t}{specs : ZnZ.Specs ops}. - - Definition mul_add:= w_mul_add ZnZ.zero ZnZ.succ ZnZ.add_c ZnZ.mul_c. - - Notation "[| x |]" := (ZnZ.to_Z x) (at level 0, x at level 99). - - Notation "[|| x ||]" := - (zn2z_to_Z (base ZnZ.digits) ZnZ.to_Z x) (at level 0, x at level 99). - - Lemma spec_mul_add: forall x y z, - let (zh, zl) := mul_add x y z in - [||WW zh zl||] = [|x|] * [|y|] + [|z|]. - Proof. - intros x y z. - refine (spec_w_mul_add _ _ _ _ _ _ _ _ _ _ _ _ x y z); auto. - exact ZnZ.spec_0. - exact ZnZ.spec_to_Z. - exact ZnZ.spec_succ. - exact ZnZ.spec_add_c. - exact ZnZ.spec_mul_c. - Qed. - -End MulAdd. - - -(** Modular versions of DoubleCyclic *) - -Module DoubleCyclic (C:CyclicType) <: CyclicType. - Definition t := zn2z C.t. - Instance ops : ZnZ.Ops t := mk_zn2z_ops. - Instance specs : ZnZ.Specs ops := mk_zn2z_specs. -End DoubleCyclic. - -Module DoubleCyclicKaratsuba (C:CyclicType) <: CyclicType. - Definition t := zn2z C.t. - Definition ops : ZnZ.Ops t := mk_zn2z_ops_karatsuba. - Definition specs : ZnZ.Specs ops := mk_zn2z_specs_karatsuba. -End DoubleCyclicKaratsuba. diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleDiv.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleDiv.v deleted file mode 100644 index 09d7329b66..0000000000 --- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleDiv.v +++ /dev/null @@ -1,1494 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) -(* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) -(************************************************************************) - -Set Implicit Arguments. - -Require Import ZArith. -Require Import BigNumPrelude. -Require Import DoubleType. -Require Import DoubleBase. -Require Import DoubleDivn1. -Require Import DoubleAdd. -Require Import DoubleSub. - -Local Open Scope Z_scope. - -Ltac zarith := auto with zarith. - - -Section POS_MOD. - - Variable w:Type. - Variable w_0 : w. - Variable w_digits : positive. - Variable w_zdigits : w. - Variable w_WW : w -> w -> zn2z w. - Variable w_pos_mod : w -> w -> w. - Variable w_compare : w -> w -> comparison. - Variable ww_compare : zn2z w -> zn2z w -> comparison. - Variable w_0W : w -> zn2z w. - Variable low: zn2z w -> w. - Variable ww_sub: zn2z w -> zn2z w -> zn2z w. - Variable ww_zdigits : zn2z w. - - - Definition ww_pos_mod p x := - let zdigits := w_0W w_zdigits in - match x with - | W0 => W0 - | WW xh xl => - match ww_compare p zdigits with - | Eq => w_WW w_0 xl - | Lt => w_WW w_0 (w_pos_mod (low p) xl) - | Gt => - match ww_compare p ww_zdigits with - | Lt => - let n := low (ww_sub p zdigits) in - w_WW (w_pos_mod n xh) xl - | _ => x - end - end - end. - - - Variable w_to_Z : w -> Z. - - Notation wB := (base w_digits). - Notation wwB := (base (ww_digits w_digits)). - Notation "[| x |]" := (w_to_Z x) (at level 0, x at level 99). - - Notation "[[ x ]]" := (ww_to_Z w_digits w_to_Z x)(at level 0, x at level 99). - - - Variable spec_w_0 : [|w_0|] = 0. - - Variable spec_to_Z : forall x, 0 <= [|x|] < wB. - - Variable spec_to_w_Z : forall x, 0 <= [[x]] < wwB. - - Variable spec_w_WW : forall h l, [[w_WW h l]] = [|h|] * wB + [|l|]. - - Variable spec_pos_mod : forall w p, - [|w_pos_mod p w|] = [|w|] mod (2 ^ [|p|]). - - Variable spec_w_0W : forall l, [[w_0W l]] = [|l|]. - Variable spec_ww_compare : forall x y, - ww_compare x y = Z.compare [[x]] [[y]]. - Variable spec_ww_sub: forall x y, - [[ww_sub x y]] = ([[x]] - [[y]]) mod wwB. - - Variable spec_zdigits : [| w_zdigits |] = Zpos w_digits. - Variable spec_low: forall x, [| low x|] = [[x]] mod wB. - Variable spec_ww_zdigits : [[ww_zdigits]] = 2 * [|w_zdigits|]. - Variable spec_ww_digits : ww_digits w_digits = xO w_digits. - - - Hint Rewrite spec_w_0 spec_w_WW : w_rewrite. - - Lemma spec_ww_pos_mod : forall w p, - [[ww_pos_mod p w]] = [[w]] mod (2 ^ [[p]]). - assert (HHHHH:= lt_0_wB w_digits). - assert (F0: forall x y, x - y + y = x); auto with zarith. - intros w1 p; case (spec_to_w_Z p); intros HH1 HH2. - unfold ww_pos_mod; case w1. reflexivity. - intros xh xl; rewrite spec_ww_compare. - case Z.compare_spec; - rewrite spec_w_0W; rewrite spec_zdigits; fold wB; - intros H1. - rewrite H1; simpl ww_to_Z. - autorewrite with w_rewrite rm10. - rewrite Zplus_mod; auto with zarith. - rewrite Z_mod_mult; auto with zarith. - autorewrite with rm10. - rewrite Zmod_mod; auto with zarith. - rewrite Zmod_small; auto with zarith. - autorewrite with w_rewrite rm10. - simpl ww_to_Z. - rewrite spec_pos_mod. - assert (HH0: [|low p|] = [[p]]). - rewrite spec_low. - apply Zmod_small; auto with zarith. - case (spec_to_w_Z p); intros HHH1 HHH2; split; auto with zarith. - apply Z.lt_le_trans with (1 := H1). - unfold base; apply Zpower2_le_lin; auto with zarith. - rewrite HH0. - rewrite Zplus_mod; auto with zarith. - unfold base. - rewrite <- (F0 (Zpos w_digits) [[p]]). - rewrite Zpower_exp; auto with zarith. - rewrite Z.mul_assoc. - rewrite Z_mod_mult; auto with zarith. - autorewrite with w_rewrite rm10. - rewrite Zmod_mod; auto with zarith. - rewrite spec_ww_compare. - case Z.compare_spec; rewrite spec_ww_zdigits; - rewrite spec_zdigits; intros H2. - replace (2^[[p]]) with wwB. - rewrite Zmod_small; auto with zarith. - unfold base; rewrite H2. - rewrite spec_ww_digits; auto. - assert (HH0: [|low (ww_sub p (w_0W w_zdigits))|] = - [[p]] - Zpos w_digits). - rewrite spec_low. - rewrite spec_ww_sub. - rewrite spec_w_0W; rewrite spec_zdigits. - rewrite <- Zmod_div_mod; auto with zarith. - rewrite Zmod_small; auto with zarith. - split; auto with zarith. - apply Z.lt_le_trans with (Zpos w_digits); auto with zarith. - unfold base; apply Zpower2_le_lin; auto with zarith. - exists wB; unfold base; rewrite <- Zpower_exp; auto with zarith. - rewrite spec_ww_digits; - apply f_equal with (f := Z.pow 2); rewrite Pos2Z.inj_xO; auto with zarith. - simpl ww_to_Z; autorewrite with w_rewrite. - rewrite spec_pos_mod; rewrite HH0. - pattern [|xh|] at 2; - rewrite Z_div_mod_eq with (b := 2 ^ ([[p]] - Zpos w_digits)); - auto with zarith. - rewrite (fun x => (Z.mul_comm (2 ^ x))); rewrite Z.mul_add_distr_r. - unfold base; rewrite <- Z.mul_assoc; rewrite <- Zpower_exp; - auto with zarith. - rewrite F0; auto with zarith. - rewrite <- Z.add_assoc; rewrite Zplus_mod; auto with zarith. - rewrite Z_mod_mult; auto with zarith. - autorewrite with rm10. - rewrite Zmod_mod; auto with zarith. - symmetry; apply Zmod_small; auto with zarith. - case (spec_to_Z xh); intros U1 U2. - case (spec_to_Z xl); intros U3 U4. - split; auto with zarith. - apply Z.add_nonneg_nonneg; auto with zarith. - apply Z.mul_nonneg_nonneg; auto with zarith. - match goal with |- 0 <= ?X mod ?Y => - case (Z_mod_lt X Y); auto with zarith - end. - match goal with |- ?X mod ?Y * ?U + ?Z < ?T => - apply Z.le_lt_trans with ((Y - 1) * U + Z ); - [case (Z_mod_lt X Y); auto with zarith | idtac] - end. - match goal with |- ?X * ?U + ?Y < ?Z => - apply Z.le_lt_trans with (X * U + (U - 1)) - end. - apply Z.add_le_mono_l; auto with zarith. - case (spec_to_Z xl); unfold base; auto with zarith. - rewrite Z.mul_sub_distr_r; rewrite <- Zpower_exp; auto with zarith. - rewrite F0; auto with zarith. - rewrite Zmod_small; auto with zarith. - case (spec_to_w_Z (WW xh xl)); intros U1 U2. - split; auto with zarith. - apply Z.lt_le_trans with (1:= U2). - unfold base; rewrite spec_ww_digits. - apply Zpower_le_monotone; auto with zarith. - split; auto with zarith. - rewrite Pos2Z.inj_xO; auto with zarith. - Qed. - -End POS_MOD. - -Section DoubleDiv32. - - Variable w : Type. - Variable w_0 : w. - Variable w_Bm1 : w. - Variable w_Bm2 : w. - Variable w_WW : w -> w -> zn2z w. - Variable w_compare : w -> w -> comparison. - Variable w_add_c : w -> w -> carry w. - Variable w_add_carry_c : w -> w -> carry w. - Variable w_add : w -> w -> w. - Variable w_add_carry : w -> w -> w. - Variable w_pred : w -> w. - Variable w_sub : w -> w -> w. - Variable w_mul_c : w -> w -> zn2z w. - Variable w_div21 : w -> w -> w -> w*w. - Variable ww_sub_c : zn2z w -> zn2z w -> carry (zn2z w). - - Definition w_div32_body a1 a2 a3 b1 b2 := - match w_compare a1 b1 with - | Lt => - let (q,r) := w_div21 a1 a2 b1 in - match ww_sub_c (w_WW r a3) (w_mul_c q b2) with - | C0 r1 => (q,r1) - | C1 r1 => - let q := w_pred q in - ww_add_c_cont w_WW w_add_c w_add_carry_c - (fun r2=>(w_pred q, ww_add w_add_c w_add w_add_carry r2 (WW b1 b2))) - (fun r2 => (q,r2)) - r1 (WW b1 b2) - end - | Eq => - ww_add_c_cont w_WW w_add_c w_add_carry_c - (fun r => (w_Bm2, ww_add w_add_c w_add w_add_carry r (WW b1 b2))) - (fun r => (w_Bm1,r)) - (WW (w_sub a2 b2) a3) (WW b1 b2) - | Gt => (w_0, W0) (* cas absurde *) - end. - - Definition w_div32 a1 a2 a3 b1 b2 := - Eval lazy beta iota delta [ww_add_c_cont ww_add w_div32_body] in - w_div32_body a1 a2 a3 b1 b2. - - (* Proof *) - - Variable w_digits : positive. - Variable w_to_Z : w -> Z. - - Notation wB := (base w_digits). - Notation wwB := (base (ww_digits w_digits)). - Notation "[| x |]" := (w_to_Z x) (at level 0, x at level 99). - Notation "[+| c |]" := - (interp_carry 1 wB w_to_Z c) (at level 0, c at level 99). - Notation "[-| c |]" := - (interp_carry (-1) wB w_to_Z c) (at level 0, c at level 99). - - Notation "[[ x ]]" := (ww_to_Z w_digits w_to_Z x)(at level 0, x at level 99). - Notation "[-[ c ]]" := - (interp_carry (-1) wwB (ww_to_Z w_digits w_to_Z) c) - (at level 0, c at level 99). - - - Variable spec_w_0 : [|w_0|] = 0. - Variable spec_w_Bm1 : [|w_Bm1|] = wB - 1. - Variable spec_w_Bm2 : [|w_Bm2|] = wB - 2. - - Variable spec_to_Z : forall x, 0 <= [|x|] < wB. - - Variable spec_w_WW : forall h l, [[w_WW h l]] = [|h|] * wB + [|l|]. - Variable spec_compare : - forall x y, w_compare x y = Z.compare [|x|] [|y|]. - Variable spec_w_add_c : forall x y, [+|w_add_c x y|] = [|x|] + [|y|]. - Variable spec_w_add_carry_c : - forall x y, [+|w_add_carry_c x y|] = [|x|] + [|y|] + 1. - - Variable spec_w_add : forall x y, [|w_add x y|] = ([|x|] + [|y|]) mod wB. - Variable spec_w_add_carry : - forall x y, [|w_add_carry x y|] = ([|x|] + [|y|] + 1) mod wB. - - Variable spec_pred : forall x, [|w_pred x|] = ([|x|] - 1) mod wB. - Variable spec_sub : forall x y, [|w_sub x y|] = ([|x|] - [|y|]) mod wB. - - Variable spec_mul_c : forall x y, [[ w_mul_c x y ]] = [|x|] * [|y|]. - Variable spec_div21 : forall a1 a2 b, - wB/2 <= [|b|] -> - [|a1|] < [|b|] -> - let (q,r) := w_div21 a1 a2 b in - [|a1|] *wB+ [|a2|] = [|q|] * [|b|] + [|r|] /\ - 0 <= [|r|] < [|b|]. - - Variable spec_ww_sub_c : forall x y, [-[ww_sub_c x y]] = [[x]] - [[y]]. - - Ltac Spec_w_to_Z x := - let H:= fresh "HH" in - assert (H:= spec_to_Z x). - Ltac Spec_ww_to_Z x := - let H:= fresh "HH" in - assert (H:= spec_ww_to_Z w_digits w_to_Z spec_to_Z x). - - Theorem wB_div2: forall x, wB/2 <= x -> wB <= 2 * x. - intros x H; rewrite <- wB_div_2; apply Z.mul_le_mono_nonneg_l; auto with zarith. - Qed. - - Lemma Zmult_lt_0_reg_r_2 : forall n m : Z, 0 <= n -> 0 < m * n -> 0 < m. - Proof. - intros n m H1 H2;apply Z.mul_pos_cancel_r with n;trivial. - Z.le_elim H1; trivial. - subst;rewrite Z.mul_0_r in H2;discriminate H2. - Qed. - - Theorem spec_w_div32 : forall a1 a2 a3 b1 b2, - wB/2 <= [|b1|] -> - [[WW a1 a2]] < [[WW b1 b2]] -> - let (q,r) := w_div32 a1 a2 a3 b1 b2 in - [|a1|] * wwB + [|a2|] * wB + [|a3|] = - [|q|] * ([|b1|] * wB + [|b2|]) + [[r]] /\ - 0 <= [[r]] < [|b1|] * wB + [|b2|]. - Proof. - intros a1 a2 a3 b1 b2 Hle Hlt. - assert (U:= lt_0_wB w_digits); assert (U1:= lt_0_wwB w_digits). - Spec_w_to_Z a1;Spec_w_to_Z a2;Spec_w_to_Z a3;Spec_w_to_Z b1;Spec_w_to_Z b2. - rewrite wwB_wBwB; rewrite Z.pow_2_r; rewrite Z.mul_assoc;rewrite <- Z.mul_add_distr_r. - change (w_div32 a1 a2 a3 b1 b2) with (w_div32_body a1 a2 a3 b1 b2). - unfold w_div32_body. - rewrite spec_compare. case Z.compare_spec; intro Hcmp. - simpl in Hlt. - rewrite Hcmp in Hlt;assert ([|a2|] < [|b2|]). omega. - assert ([[WW (w_sub a2 b2) a3]] = ([|a2|]-[|b2|])*wB + [|a3|] + wwB). - simpl;rewrite spec_sub. - assert ([|a2|] - [|b2|] = wB*(-1) + ([|a2|] - [|b2|] + wB)). ring. - assert (0 <= [|a2|] - [|b2|] + wB < wB). omega. - rewrite <-(Zmod_unique ([|a2|]-[|b2|]) wB (-1) ([|a2|]-[|b2|]+wB) H1 H0). - rewrite wwB_wBwB;ring. - assert (U2 := wB_pos w_digits). - eapply spec_ww_add_c_cont with (P := - fun (x y:zn2z w) (res:w*zn2z w) => - let (q, r) := res in - ([|a1|] * wB + [|a2|]) * wB + [|a3|] = - [|q|] * ([|b1|] * wB + [|b2|]) + [[r]] /\ - 0 <= [[r]] < [|b1|] * wB + [|b2|]);eauto. - rewrite H0;intros r. - repeat - (rewrite spec_ww_add;eauto || rewrite spec_w_Bm1 || rewrite spec_w_Bm2); - simpl ww_to_Z;try rewrite Z.mul_1_l;intros H1. - assert (0<= ([[r]] + ([|b1|] * wB + [|b2|])) - wwB < [|b1|] * wB + [|b2|]). - Spec_ww_to_Z r;split;zarith. - rewrite H1. - assert (H12:= wB_div2 Hle). assert (wwB <= 2 * [|b1|] * wB). - rewrite wwB_wBwB; rewrite Z.pow_2_r; zarith. - assert (-wwB < ([|a2|] - [|b2|]) * wB + [|a3|] < 0). - split. apply Z.lt_le_trans with (([|a2|] - [|b2|]) * wB);zarith. - rewrite wwB_wBwB;replace (-(wB^2)) with (-wB*wB);[zarith | ring]. - apply Z.mul_lt_mono_pos_r;zarith. - apply Z.le_lt_trans with (([|a2|] - [|b2|]) * wB + (wB -1));zarith. - replace ( ([|a2|] - [|b2|]) * wB + (wB - 1)) with - (([|a2|] - [|b2|] + 1) * wB + - 1);[zarith | ring]. - assert (([|a2|] - [|b2|] + 1) * wB <= 0);zarith. - replace 0 with (0*wB);zarith. - replace (([|a2|] - [|b2|]) * wB + [|a3|] + wwB + ([|b1|] * wB + [|b2|]) + - ([|b1|] * wB + [|b2|]) - wwB) with - (([|a2|] - [|b2|]) * wB + [|a3|] + 2*[|b1|] * wB + 2*[|b2|]); - [zarith | ring]. - rewrite <- (Zmod_unique ([[r]] + ([|b1|] * wB + [|b2|])) wwB - 1 ([[r]] + ([|b1|] * wB + [|b2|]) - wwB));zarith;try (ring;fail). - split. rewrite H1;rewrite Hcmp;ring. trivial. - Spec_ww_to_Z (WW b1 b2). simpl in HH4;zarith. - rewrite H0;intros r;repeat - (rewrite spec_w_Bm1 || rewrite spec_w_Bm2); - simpl ww_to_Z;try rewrite Z.mul_1_l;intros H1. - assert ([[r]]=([|a2|]-[|b2|])*wB+[|a3|]+([|b1|]*wB+[|b2|])). zarith. - split. rewrite H2;rewrite Hcmp;ring. - split. Spec_ww_to_Z r;zarith. - rewrite H2. - assert (([|a2|] - [|b2|]) * wB + [|a3|] < 0);zarith. - apply Z.le_lt_trans with (([|a2|] - [|b2|]) * wB + (wB -1));zarith. - replace ( ([|a2|] - [|b2|]) * wB + (wB - 1)) with - (([|a2|] - [|b2|] + 1) * wB + - 1);[zarith|ring]. - assert (([|a2|] - [|b2|] + 1) * wB <= 0);zarith. - replace 0 with (0*wB);zarith. - (* Cas Lt *) - assert (Hdiv21 := spec_div21 a2 Hle Hcmp); - destruct (w_div21 a1 a2 b1) as (q, r);destruct Hdiv21. - rewrite H. - assert (Hq := spec_to_Z q). - generalize - (spec_ww_sub_c (w_WW r a3) (w_mul_c q b2)); - destruct (ww_sub_c (w_WW r a3) (w_mul_c q b2)) - as [r1|r1];repeat (rewrite spec_w_WW || rewrite spec_mul_c); - unfold interp_carry;intros H1. - rewrite H1. - split. ring. split. - rewrite <- H1;destruct (spec_ww_to_Z w_digits w_to_Z spec_to_Z r1);trivial. - apply Z.le_lt_trans with ([|r|] * wB + [|a3|]). - assert ( 0 <= [|q|] * [|b2|]);zarith. - apply beta_lex_inv;zarith. - assert ([[r1]] = [|r|] * wB + [|a3|] - [|q|] * [|b2|] + wwB). - rewrite <- H1;ring. - Spec_ww_to_Z r1; assert (0 <= [|r|]*wB). zarith. - assert (0 < [|q|] * [|b2|]). zarith. - assert (0 < [|q|]). - apply Zmult_lt_0_reg_r_2 with [|b2|];zarith. - eapply spec_ww_add_c_cont with (P := - fun (x y:zn2z w) (res:w*zn2z w) => - let (q0, r0) := res in - ([|q|] * [|b1|] + [|r|]) * wB + [|a3|] = - [|q0|] * ([|b1|] * wB + [|b2|]) + [[r0]] /\ - 0 <= [[r0]] < [|b1|] * wB + [|b2|]);eauto. - intros r2;repeat (rewrite spec_pred || rewrite spec_ww_add;eauto); - simpl ww_to_Z;intros H7. - assert (0 < [|q|] - 1). - assert (H6 : 1 <= [|q|]) by zarith. - Z.le_elim H6;zarith. - rewrite <- H6 in H2;rewrite H2 in H7. - assert (0 < [|b1|]*wB). apply Z.mul_pos_pos;zarith. - Spec_ww_to_Z r2. zarith. - rewrite (Zmod_small ([|q|] -1));zarith. - rewrite (Zmod_small ([|q|] -1 -1));zarith. - assert ([[r2]] + ([|b1|] * wB + [|b2|]) = - wwB * 1 + - ([|r|] * wB + [|a3|] - [|q|] * [|b2|] + 2 * ([|b1|] * wB + [|b2|]))). - rewrite H7;rewrite H2;ring. - assert - ([|r|]*wB + [|a3|] - [|q|]*[|b2|] + 2 * ([|b1|]*wB + [|b2|]) - < [|b1|]*wB + [|b2|]). - Spec_ww_to_Z r2;omega. - Spec_ww_to_Z (WW b1 b2). simpl in HH5. - assert - (0 <= [|r|]*wB + [|a3|] - [|q|]*[|b2|] + 2 * ([|b1|]*wB + [|b2|]) - < wwB). split;try omega. - replace (2*([|b1|]*wB+[|b2|])) with ((2*[|b1|])*wB+2*[|b2|]). 2:ring. - assert (H12:= wB_div2 Hle). assert (wwB <= 2 * [|b1|] * wB). - rewrite wwB_wBwB; rewrite Z.pow_2_r; zarith. omega. - rewrite <- (Zmod_unique - ([[r2]] + ([|b1|] * wB + [|b2|])) - wwB - 1 - ([|r|] * wB + [|a3|] - [|q|] * [|b2|] + 2*([|b1|] * wB + [|b2|])) - H10 H8). - split. ring. zarith. - intros r2;repeat (rewrite spec_pred);simpl ww_to_Z;intros H7. - rewrite (Zmod_small ([|q|] -1));zarith. - split. - replace [[r2]] with ([[r1]] + ([|b1|] * wB + [|b2|]) -wwB). - rewrite H2; ring. rewrite <- H7; ring. - Spec_ww_to_Z r2;Spec_ww_to_Z r1. omega. - simpl in Hlt. - assert ([|a1|] * wB + [|a2|] <= [|b1|] * wB + [|b2|]). zarith. - assert (H1 := beta_lex _ _ _ _ _ H HH0 HH3). rewrite spec_w_0;simpl;zarith. - Qed. - - -End DoubleDiv32. - -Section DoubleDiv21. - Variable w : Type. - Variable w_0 : w. - - Variable w_0W : w -> zn2z w. - Variable w_div32 : w -> w -> w -> w -> w -> w * zn2z w. - - Variable ww_1 : zn2z w. - Variable ww_compare : zn2z w -> zn2z w -> comparison. - Variable ww_sub : zn2z w -> zn2z w -> zn2z w. - - - Definition ww_div21 a1 a2 b := - match a1 with - | W0 => - match ww_compare a2 b with - | Gt => (ww_1, ww_sub a2 b) - | Eq => (ww_1, W0) - | Lt => (W0, a2) - end - | WW a1h a1l => - match a2 with - | W0 => - match b with - | W0 => (W0,W0) (* cas absurde *) - | WW b1 b2 => - let (q1, r) := w_div32 a1h a1l w_0 b1 b2 in - match r with - | W0 => (WW q1 w_0, W0) - | WW r1 r2 => - let (q2, s) := w_div32 r1 r2 w_0 b1 b2 in - (WW q1 q2, s) - end - end - | WW a2h a2l => - match b with - | W0 => (W0,W0) (* cas absurde *) - | WW b1 b2 => - let (q1, r) := w_div32 a1h a1l a2h b1 b2 in - match r with - | W0 => (WW q1 w_0, w_0W a2l) - | WW r1 r2 => - let (q2, s) := w_div32 r1 r2 a2l b1 b2 in - (WW q1 q2, s) - end - end - end - end. - - (* Proof *) - - Variable w_digits : positive. - Variable w_to_Z : w -> Z. - Notation wB := (base w_digits). - Notation wwB := (base (ww_digits w_digits)). - Notation "[| x |]" := (w_to_Z x) (at level 0, x at level 99). - Notation "[[ x ]]" := (ww_to_Z w_digits w_to_Z x)(at level 0, x at level 99). - Notation "[-[ c ]]" := - (interp_carry (-1) wwB (ww_to_Z w_digits w_to_Z) c) - (at level 0, c at level 99). - - Variable spec_w_0 : [|w_0|] = 0. - Variable spec_to_Z : forall x, 0 <= [|x|] < wB. - Variable spec_w_0W : forall l, [[w_0W l]] = [|l|]. - Variable spec_w_div32 : forall a1 a2 a3 b1 b2, - wB/2 <= [|b1|] -> - [[WW a1 a2]] < [[WW b1 b2]] -> - let (q,r) := w_div32 a1 a2 a3 b1 b2 in - [|a1|] * wwB + [|a2|] * wB + [|a3|] = - [|q|] * ([|b1|] * wB + [|b2|]) + [[r]] /\ - 0 <= [[r]] < [|b1|] * wB + [|b2|]. - Variable spec_ww_1 : [[ww_1]] = 1. - Variable spec_ww_compare : forall x y, - ww_compare x y = Z.compare [[x]] [[y]]. - Variable spec_ww_sub : forall x y, [[ww_sub x y]] = ([[x]] - [[y]]) mod wwB. - - Theorem wwB_div: wwB = 2 * (wwB / 2). - Proof. - rewrite wwB_div_2; rewrite Z.mul_assoc; rewrite wB_div_2; auto. - rewrite <- Z.pow_2_r; apply wwB_wBwB. - Qed. - - Ltac Spec_w_to_Z x := - let H:= fresh "HH" in - assert (H:= spec_to_Z x). - Ltac Spec_ww_to_Z x := - let H:= fresh "HH" in - assert (H:= spec_ww_to_Z w_digits w_to_Z spec_to_Z x). - - Theorem spec_ww_div21 : forall a1 a2 b, - wwB/2 <= [[b]] -> - [[a1]] < [[b]] -> - let (q,r) := ww_div21 a1 a2 b in - [[a1]] *wwB+[[a2]] = [[q]] * [[b]] + [[r]] /\ 0 <= [[r]] < [[b]]. - Proof. - assert (U:= lt_0_wB w_digits). - assert (U1:= lt_0_wwB w_digits). - intros a1 a2 b H Hlt; unfold ww_div21. - Spec_ww_to_Z b; assert (Eq: 0 < [[b]]). Spec_ww_to_Z a1;omega. - generalize Hlt H ;clear Hlt H;case a1. - intros H1 H2;simpl in H1;Spec_ww_to_Z a2. - rewrite spec_ww_compare. case Z.compare_spec; - simpl;try rewrite spec_ww_1;autorewrite with rm10; intros;zarith. - rewrite spec_ww_sub;simpl. rewrite Zmod_small;zarith. - split. ring. - assert (wwB <= 2*[[b]]);zarith. - rewrite wwB_div;zarith. - intros a1h a1l. Spec_w_to_Z a1h;Spec_w_to_Z a1l. Spec_ww_to_Z a2. - destruct a2 as [ |a3 a4]; - (destruct b as [ |b1 b2];[unfold Z.le in Eq;discriminate Eq|idtac]); - try (Spec_w_to_Z a3; Spec_w_to_Z a4); Spec_w_to_Z b1; Spec_w_to_Z b2; - intros Hlt H; match goal with |-context [w_div32 ?X ?Y ?Z ?T ?U] => - generalize (@spec_w_div32 X Y Z T U); case (w_div32 X Y Z T U); - intros q1 r H0 - end; (assert (Eq1: wB / 2 <= [|b1|]);[ - apply (@beta_lex (wB / 2) 0 [|b1|] [|b2|] wB); auto with zarith; - autorewrite with rm10;repeat rewrite (Z.mul_comm wB); - rewrite <- wwB_div_2; trivial - | generalize (H0 Eq1 Hlt);clear H0;destruct r as [ |r1 r2];simpl; - try rewrite spec_w_0; try rewrite spec_w_0W;repeat rewrite Z.add_0_r; - intros (H1,H2) ]). - split;[rewrite wwB_wBwB; rewrite Z.pow_2_r | trivial]. - rewrite Z.mul_assoc;rewrite Z.mul_add_distr_r;rewrite <- Z.mul_assoc; - rewrite <- Z.pow_2_r; rewrite <- wwB_wBwB;rewrite H1;ring. - destruct H2 as (H2,H3);match goal with |-context [w_div32 ?X ?Y ?Z ?T ?U] => - generalize (@spec_w_div32 X Y Z T U); case (w_div32 X Y Z T U); - intros q r H0;generalize (H0 Eq1 H3);clear H0;intros (H4,H5) end. - split;[rewrite wwB_wBwB | trivial]. - rewrite Z.pow_2_r. - rewrite Z.mul_assoc;rewrite Z.mul_add_distr_r;rewrite <- Z.mul_assoc; - rewrite <- Z.pow_2_r. - rewrite <- wwB_wBwB;rewrite H1. - rewrite spec_w_0 in H4;rewrite Z.add_0_r in H4. - repeat rewrite Z.mul_add_distr_r. rewrite <- (Z.mul_assoc [|r1|]). - rewrite <- Z.pow_2_r; rewrite <- wwB_wBwB;rewrite H4;simpl;ring. - split;[rewrite wwB_wBwB | split;zarith]. - replace (([|a1h|] * wB + [|a1l|]) * wB^2 + ([|a3|] * wB + [|a4|])) - with (([|a1h|] * wwB + [|a1l|] * wB + [|a3|])*wB+ [|a4|]). - rewrite H1;ring. rewrite wwB_wBwB;ring. - change [|a4|] with (0*wB+[|a4|]);apply beta_lex_inv;zarith. - assert (1 <= wB/2);zarith. - assert (H_:= wB_pos w_digits);apply Zdiv_le_lower_bound;zarith. - destruct H2 as (H2,H3);match goal with |-context [w_div32 ?X ?Y ?Z ?T ?U] => - generalize (@spec_w_div32 X Y Z T U); case (w_div32 X Y Z T U); - intros q r H0;generalize (H0 Eq1 H3);clear H0;intros (H4,H5) end. - split;trivial. - replace (([|a1h|] * wB + [|a1l|]) * wwB + ([|a3|] * wB + [|a4|])) with - (([|a1h|] * wwB + [|a1l|] * wB + [|a3|])*wB + [|a4|]); - [rewrite H1 | rewrite wwB_wBwB;ring]. - replace (([|q1|]*([|b1|]*wB+[|b2|])+([|r1|]*wB+[|r2|]))*wB+[|a4|]) with - (([|q1|]*([|b1|]*wB+[|b2|]))*wB+([|r1|]*wwB+[|r2|]*wB+[|a4|])); - [rewrite H4;simpl|rewrite wwB_wBwB];ring. - Qed. - -End DoubleDiv21. - -Section DoubleDivGt. - Variable w : Type. - Variable w_digits : positive. - Variable w_0 : w. - - Variable w_WW : w -> w -> zn2z w. - Variable w_0W : w -> zn2z w. - Variable w_compare : w -> w -> comparison. - Variable w_eq0 : w -> bool. - Variable w_opp_c : w -> carry w. - Variable w_opp w_opp_carry : w -> w. - Variable w_sub_c : w -> w -> carry w. - Variable w_sub w_sub_carry : w -> w -> w. - - Variable w_div_gt : w -> w -> w*w. - Variable w_mod_gt : w -> w -> w. - Variable w_gcd_gt : w -> w -> w. - Variable w_add_mul_div : w -> w -> w -> w. - Variable w_head0 : w -> w. - Variable w_div21 : w -> w -> w -> w * w. - Variable w_div32 : w -> w -> w -> w -> w -> w * zn2z w. - - - Variable _ww_zdigits : zn2z w. - Variable ww_1 : zn2z w. - Variable ww_add_mul_div : zn2z w -> zn2z w -> zn2z w -> zn2z w. - - Variable w_zdigits : w. - - Definition ww_div_gt_aux ah al bh bl := - Eval lazy beta iota delta [ww_sub ww_opp] in - let p := w_head0 bh in - match w_compare p w_0 with - | Gt => - let b1 := w_add_mul_div p bh bl in - let b2 := w_add_mul_div p bl w_0 in - let a1 := w_add_mul_div p w_0 ah in - let a2 := w_add_mul_div p ah al in - let a3 := w_add_mul_div p al w_0 in - let (q,r) := w_div32 a1 a2 a3 b1 b2 in - (WW w_0 q, ww_add_mul_div - (ww_sub w_0 w_WW w_opp_c w_opp_carry w_sub_c - w_opp w_sub w_sub_carry _ww_zdigits (w_0W p)) W0 r) - | _ => (ww_1, ww_sub w_0 w_WW w_opp_c w_opp_carry w_sub_c - w_opp w_sub w_sub_carry (WW ah al) (WW bh bl)) - end. - - Definition ww_div_gt a b := - Eval lazy beta iota delta [ww_div_gt_aux double_divn1 - double_divn1_p double_divn1_p_aux double_divn1_0 double_divn1_0_aux - double_split double_0 double_WW] in - match a, b with - | W0, _ => (W0,W0) - | _, W0 => (W0,W0) - | WW ah al, WW bh bl => - if w_eq0 ah then - let (q,r) := w_div_gt al bl in - (WW w_0 q, w_0W r) - else - match w_compare w_0 bh with - | Eq => - let(q,r):= - double_divn1 w_zdigits w_0 w_WW w_head0 w_add_mul_div w_div21 - w_compare w_sub 1 a bl in - (q, w_0W r) - | Lt => ww_div_gt_aux ah al bh bl - | Gt => (W0,W0) (* cas absurde *) - end - end. - - Definition ww_mod_gt_aux ah al bh bl := - Eval lazy beta iota delta [ww_sub ww_opp] in - let p := w_head0 bh in - match w_compare p w_0 with - | Gt => - let b1 := w_add_mul_div p bh bl in - let b2 := w_add_mul_div p bl w_0 in - let a1 := w_add_mul_div p w_0 ah in - let a2 := w_add_mul_div p ah al in - let a3 := w_add_mul_div p al w_0 in - let (q,r) := w_div32 a1 a2 a3 b1 b2 in - ww_add_mul_div (ww_sub w_0 w_WW w_opp_c w_opp_carry w_sub_c - w_opp w_sub w_sub_carry _ww_zdigits (w_0W p)) W0 r - | _ => - ww_sub w_0 w_WW w_opp_c w_opp_carry w_sub_c - w_opp w_sub w_sub_carry (WW ah al) (WW bh bl) - end. - - Definition ww_mod_gt a b := - Eval lazy beta iota delta [ww_mod_gt_aux double_modn1 - double_modn1_p double_modn1_p_aux double_modn1_0 double_modn1_0_aux - double_split double_0 double_WW snd] in - match a, b with - | W0, _ => W0 - | _, W0 => W0 - | WW ah al, WW bh bl => - if w_eq0 ah then w_0W (w_mod_gt al bl) - else - match w_compare w_0 bh with - | Eq => - w_0W (double_modn1 w_zdigits w_0 w_head0 w_add_mul_div w_div21 - w_compare w_sub 1 a bl) - | Lt => ww_mod_gt_aux ah al bh bl - | Gt => W0 (* cas absurde *) - end - end. - - Definition ww_gcd_gt_body (cont: w->w->w->w->zn2z w) (ah al bh bl: w) := - Eval lazy beta iota delta [ww_mod_gt_aux double_modn1 - double_modn1_p double_modn1_p_aux double_modn1_0 double_modn1_0_aux - double_split double_0 double_WW snd] in - match w_compare w_0 bh with - | Eq => - match w_compare w_0 bl with - | Eq => WW ah al (* normalement n'arrive pas si forme normale *) - | Lt => - let m := double_modn1 w_zdigits w_0 w_head0 w_add_mul_div w_div21 - w_compare w_sub 1 (WW ah al) bl in - WW w_0 (w_gcd_gt bl m) - | Gt => W0 (* absurde *) - end - | Lt => - let m := ww_mod_gt_aux ah al bh bl in - match m with - | W0 => WW bh bl - | WW mh ml => - match w_compare w_0 mh with - | Eq => - match w_compare w_0 ml with - | Eq => WW bh bl - | _ => - let r := double_modn1 w_zdigits w_0 w_head0 w_add_mul_div w_div21 - w_compare w_sub 1 (WW bh bl) ml in - WW w_0 (w_gcd_gt ml r) - end - | Lt => - let r := ww_mod_gt_aux bh bl mh ml in - match r with - | W0 => m - | WW rh rl => cont mh ml rh rl - end - | Gt => W0 (* absurde *) - end - end - | Gt => W0 (* absurde *) - end. - - Fixpoint ww_gcd_gt_aux - (p:positive) (cont: w -> w -> w -> w -> zn2z w) (ah al bh bl : w) - {struct p} : zn2z w := - ww_gcd_gt_body - (fun mh ml rh rl => match p with - | xH => cont mh ml rh rl - | xO p => ww_gcd_gt_aux p (ww_gcd_gt_aux p cont) mh ml rh rl - | xI p => ww_gcd_gt_aux p (ww_gcd_gt_aux p cont) mh ml rh rl - end) ah al bh bl. - - - (* Proof *) - - Variable w_to_Z : w -> Z. - Notation wB := (base w_digits). - Notation wwB := (base (ww_digits w_digits)). - Notation "[| x |]" := (w_to_Z x) (at level 0, x at level 99). - Notation "[-| c |]" := - (interp_carry (-1) wB w_to_Z c) (at level 0, c at level 99). - - Notation "[[ x ]]" := (ww_to_Z w_digits w_to_Z x)(at level 0, x at level 99). - - Variable spec_w_0 : [|w_0|] = 0. - Variable spec_to_Z : forall x, 0 <= [|x|] < wB. - Variable spec_to_w_Z : forall x, 0 <= [[x]] < wwB. - - Variable spec_w_WW : forall h l, [[w_WW h l]] = [|h|] * wB + [|l|]. - Variable spec_w_0W : forall l, [[w_0W l]] = [|l|]. - Variable spec_compare : - forall x y, w_compare x y = Z.compare [|x|] [|y|]. - Variable spec_eq0 : forall x, w_eq0 x = true -> [|x|] = 0. - - Variable spec_opp_c : forall x, [-|w_opp_c x|] = -[|x|]. - Variable spec_opp : forall x, [|w_opp x|] = (-[|x|]) mod wB. - Variable spec_opp_carry : forall x, [|w_opp_carry x|] = wB - [|x|] - 1. - - Variable spec_sub_c : forall x y, [-|w_sub_c x y|] = [|x|] - [|y|]. - Variable spec_sub : forall x y, [|w_sub x y|] = ([|x|] - [|y|]) mod wB. - Variable spec_sub_carry : - forall x y, [|w_sub_carry x y|] = ([|x|] - [|y|] - 1) mod wB. - - Variable spec_div_gt : forall a b, [|a|] > [|b|] -> 0 < [|b|] -> - let (q,r) := w_div_gt a b in - [|a|] = [|q|] * [|b|] + [|r|] /\ - 0 <= [|r|] < [|b|]. - Variable spec_mod_gt : forall a b, [|a|] > [|b|] -> 0 < [|b|] -> - [|w_mod_gt a b|] = [|a|] mod [|b|]. - Variable spec_gcd_gt : forall a b, [|a|] > [|b|] -> - Zis_gcd [|a|] [|b|] [|w_gcd_gt a b|]. - - Variable spec_add_mul_div : forall x y p, - [|p|] <= Zpos w_digits -> - [| w_add_mul_div p x y |] = - ([|x|] * (2 ^ ([|p|])) + - [|y|] / (2 ^ ((Zpos w_digits) - [|p|]))) mod wB. - Variable spec_head0 : forall x, 0 < [|x|] -> - wB/ 2 <= 2 ^ [|w_head0 x|] * [|x|] < wB. - - Variable spec_div21 : forall a1 a2 b, - wB/2 <= [|b|] -> - [|a1|] < [|b|] -> - let (q,r) := w_div21 a1 a2 b in - [|a1|] *wB+ [|a2|] = [|q|] * [|b|] + [|r|] /\ - 0 <= [|r|] < [|b|]. - - Variable spec_w_div32 : forall a1 a2 a3 b1 b2, - wB/2 <= [|b1|] -> - [[WW a1 a2]] < [[WW b1 b2]] -> - let (q,r) := w_div32 a1 a2 a3 b1 b2 in - [|a1|] * wwB + [|a2|] * wB + [|a3|] = - [|q|] * ([|b1|] * wB + [|b2|]) + [[r]] /\ - 0 <= [[r]] < [|b1|] * wB + [|b2|]. - - Variable spec_w_zdigits: [|w_zdigits|] = Zpos w_digits. - - Variable spec_ww_digits_ : [[_ww_zdigits]] = Zpos (xO w_digits). - Variable spec_ww_1 : [[ww_1]] = 1. - Variable spec_ww_add_mul_div : forall x y p, - [[p]] <= Zpos (xO w_digits) -> - [[ ww_add_mul_div p x y ]] = - ([[x]] * (2^[[p]]) + - [[y]] / (2^(Zpos (xO w_digits) - [[p]]))) mod wwB. - - Ltac Spec_w_to_Z x := - let H:= fresh "HH" in - assert (H:= spec_to_Z x). - - Ltac Spec_ww_to_Z x := - let H:= fresh "HH" in - assert (H:= spec_ww_to_Z w_digits w_to_Z spec_to_Z x). - - Lemma to_Z_div_minus_p : forall x p, - 0 < [|p|] < Zpos w_digits -> - 0 <= [|x|] / 2 ^ (Zpos w_digits - [|p|]) < 2 ^ [|p|]. - Proof. - intros x p H;Spec_w_to_Z x. - split. apply Zdiv_le_lower_bound;zarith. - apply Zdiv_lt_upper_bound;zarith. - rewrite <- Zpower_exp;zarith. - ring_simplify ([|p|] + (Zpos w_digits - [|p|])); unfold base in HH;zarith. - Qed. - Hint Resolve to_Z_div_minus_p : zarith. - - Lemma spec_ww_div_gt_aux : forall ah al bh bl, - [[WW ah al]] > [[WW bh bl]] -> - 0 < [|bh|] -> - let (q,r) := ww_div_gt_aux ah al bh bl in - [[WW ah al]] = [[q]] * [[WW bh bl]] + [[r]] /\ - 0 <= [[r]] < [[WW bh bl]]. - Proof. - intros ah al bh bl Hgt Hpos;unfold ww_div_gt_aux. - change - (let (q, r) := let p := w_head0 bh in - match w_compare p w_0 with - | Gt => - let b1 := w_add_mul_div p bh bl in - let b2 := w_add_mul_div p bl w_0 in - let a1 := w_add_mul_div p w_0 ah in - let a2 := w_add_mul_div p ah al in - let a3 := w_add_mul_div p al w_0 in - let (q,r) := w_div32 a1 a2 a3 b1 b2 in - (WW w_0 q, ww_add_mul_div - (ww_sub w_0 w_WW w_opp_c w_opp_carry w_sub_c - w_opp w_sub w_sub_carry _ww_zdigits (w_0W p)) W0 r) - | _ => (ww_1, ww_sub w_0 w_WW w_opp_c w_opp_carry w_sub_c - w_opp w_sub w_sub_carry (WW ah al) (WW bh bl)) - end in [[WW ah al]]=[[q]]*[[WW bh bl]]+[[r]] /\ 0 <=[[r]]< [[WW bh bl]]). - assert (Hh := spec_head0 Hpos). - lazy zeta. - rewrite spec_compare; case Z.compare_spec; - rewrite spec_w_0; intros HH. - generalize Hh; rewrite HH; simpl Z.pow; - rewrite Z.mul_1_l; intros (HH1, HH2); clear HH. - assert (wwB <= 2*[[WW bh bl]]). - apply Z.le_trans with (2*[|bh|]*wB). - rewrite wwB_wBwB; rewrite Z.pow_2_r; apply Z.mul_le_mono_nonneg_r; zarith. - rewrite <- wB_div_2; apply Z.mul_le_mono_nonneg_l; zarith. - simpl ww_to_Z;rewrite Z.mul_add_distr_l;rewrite Z.mul_assoc. - Spec_w_to_Z bl;zarith. - Spec_ww_to_Z (WW ah al). - rewrite spec_ww_sub;eauto. - simpl;rewrite spec_ww_1;rewrite Z.mul_1_l;simpl. - simpl ww_to_Z in Hgt, H, HH;rewrite Zmod_small;split;zarith. - case (spec_to_Z (w_head0 bh)); auto with zarith. - assert ([|w_head0 bh|] < Zpos w_digits). - destruct (Z_lt_ge_dec [|w_head0 bh|] (Zpos w_digits));trivial. - exfalso. - assert (2 ^ [|w_head0 bh|] * [|bh|] >= wB);auto with zarith. - apply Z.le_ge; replace wB with (wB * 1);try ring. - Spec_w_to_Z bh;apply Z.mul_le_mono_nonneg;zarith. - unfold base;apply Zpower_le_monotone;zarith. - assert (HHHH : 0 < [|w_head0 bh|] < Zpos w_digits); auto with zarith. - assert (Hb:= Z.lt_le_incl _ _ H). - generalize (spec_add_mul_div w_0 ah Hb) - (spec_add_mul_div ah al Hb) - (spec_add_mul_div al w_0 Hb) - (spec_add_mul_div bh bl Hb) - (spec_add_mul_div bl w_0 Hb); - rewrite spec_w_0; repeat rewrite Z.mul_0_l;repeat rewrite Z.add_0_l; - rewrite Zdiv_0_l;repeat rewrite Z.add_0_r. - Spec_w_to_Z ah;Spec_w_to_Z bh. - unfold base;repeat rewrite Zmod_shift_r;zarith. - assert (H3:=to_Z_div_minus_p ah HHHH);assert(H4:=to_Z_div_minus_p al HHHH); - assert (H5:=to_Z_div_minus_p bl HHHH). - rewrite Z.mul_comm in Hh. - assert (2^[|w_head0 bh|] < wB). unfold base;apply Zpower_lt_monotone;zarith. - unfold base in H0;rewrite Zmod_small;zarith. - fold wB; rewrite (Zmod_small ([|bh|] * 2 ^ [|w_head0 bh|]));zarith. - intros U1 U2 U3 V1 V2. - generalize (@spec_w_div32 (w_add_mul_div (w_head0 bh) w_0 ah) - (w_add_mul_div (w_head0 bh) ah al) - (w_add_mul_div (w_head0 bh) al w_0) - (w_add_mul_div (w_head0 bh) bh bl) - (w_add_mul_div (w_head0 bh) bl w_0)). - destruct (w_div32 (w_add_mul_div (w_head0 bh) w_0 ah) - (w_add_mul_div (w_head0 bh) ah al) - (w_add_mul_div (w_head0 bh) al w_0) - (w_add_mul_div (w_head0 bh) bh bl) - (w_add_mul_div (w_head0 bh) bl w_0)) as (q,r). - rewrite V1;rewrite V2. rewrite Z.mul_add_distr_r. - rewrite <- (Z.add_assoc ([|bh|] * 2 ^ [|w_head0 bh|] * wB)). - unfold base;rewrite <- shift_unshift_mod;zarith. fold wB. - replace ([|bh|] * 2 ^ [|w_head0 bh|] * wB + [|bl|] * 2 ^ [|w_head0 bh|]) with - ([[WW bh bl]] * 2^[|w_head0 bh|]). 2:simpl;ring. - fold wwB. rewrite wwB_wBwB. rewrite Z.pow_2_r. rewrite U1;rewrite U2;rewrite U3. - rewrite Z.mul_assoc. rewrite Z.mul_add_distr_r. - rewrite (Z.add_assoc ([|ah|] / 2^(Zpos(w_digits) - [|w_head0 bh|])*wB * wB)). - rewrite <- Z.mul_add_distr_r. rewrite <- Z.add_assoc. - unfold base;repeat rewrite <- shift_unshift_mod;zarith. fold wB. - replace ([|ah|] * 2 ^ [|w_head0 bh|] * wB + [|al|] * 2 ^ [|w_head0 bh|]) with - ([[WW ah al]] * 2^[|w_head0 bh|]). 2:simpl;ring. - intros Hd;destruct Hd;zarith. - simpl. apply beta_lex_inv;zarith. rewrite U1;rewrite V1. - assert ([|ah|] / 2 ^ (Zpos (w_digits) - [|w_head0 bh|]) < wB/2);zarith. - apply Zdiv_lt_upper_bound;zarith. - unfold base. - replace (2^Zpos (w_digits)) with (2^(Zpos (w_digits) - 1)*2). - rewrite Z_div_mult;zarith. rewrite <- Zpower_exp;zarith. - apply Z.lt_le_trans with wB;zarith. - unfold base;apply Zpower_le_monotone;zarith. - pattern 2 at 2;replace 2 with (2^1);trivial. - rewrite <- Zpower_exp;zarith. ring_simplify (Zpos (w_digits) - 1 + 1);trivial. - change [[WW w_0 q]] with ([|w_0|]*wB+[|q|]);rewrite spec_w_0;rewrite - Z.mul_0_l;rewrite Z.add_0_l. - replace [[ww_add_mul_div (ww_sub w_0 w_WW w_opp_c w_opp_carry w_sub_c w_opp w_sub w_sub_carry - _ww_zdigits (w_0W (w_head0 bh))) W0 r]] with ([[r]]/2^[|w_head0 bh|]). - assert (0 < 2^[|w_head0 bh|]). apply Z.pow_pos_nonneg;zarith. - split. - rewrite <- (Z_div_mult [[WW ah al]] (2^[|w_head0 bh|]));zarith. - rewrite H1;rewrite Z.mul_assoc;apply Z_div_plus_l;trivial. - split;[apply Zdiv_le_lower_bound| apply Zdiv_lt_upper_bound];zarith. - rewrite spec_ww_add_mul_div. - rewrite spec_ww_sub; auto with zarith. - rewrite spec_ww_digits_. - change (Zpos (xO (w_digits))) with (2*Zpos (w_digits));zarith. - simpl ww_to_Z;rewrite Z.mul_0_l;rewrite Z.add_0_l. - rewrite spec_w_0W. - rewrite (fun x y => Zmod_small (x-y)); auto with zarith. - ring_simplify (2 * Zpos w_digits - (2 * Zpos w_digits - [|w_head0 bh|])). - rewrite Zmod_small;zarith. - split;[apply Zdiv_le_lower_bound| apply Zdiv_lt_upper_bound];zarith. - Spec_ww_to_Z r. - apply Z.lt_le_trans with wwB;zarith. - rewrite <- (Z.mul_1_r wwB);apply Z.mul_le_mono_nonneg;zarith. - split; auto with zarith. - apply Z.le_lt_trans with (2 * Zpos w_digits); auto with zarith. - unfold base, ww_digits; rewrite (Pos2Z.inj_xO w_digits). - apply Zpower2_lt_lin; auto with zarith. - rewrite spec_ww_sub; auto with zarith. - rewrite spec_ww_digits_; rewrite spec_w_0W. - rewrite Zmod_small;zarith. - rewrite Pos2Z.inj_xO; split; auto with zarith. - apply Z.le_lt_trans with (2 * Zpos w_digits); auto with zarith. - unfold base, ww_digits; rewrite (Pos2Z.inj_xO w_digits). - apply Zpower2_lt_lin; auto with zarith. - Qed. - - Lemma spec_ww_div_gt : forall a b, [[a]] > [[b]] -> 0 < [[b]] -> - let (q,r) := ww_div_gt a b in - [[a]] = [[q]] * [[b]] + [[r]] /\ - 0 <= [[r]] < [[b]]. - Proof. - intros a b Hgt Hpos;unfold ww_div_gt. - change (let (q,r) := match a, b with - | W0, _ => (W0,W0) - | _, W0 => (W0,W0) - | WW ah al, WW bh bl => - if w_eq0 ah then - let (q,r) := w_div_gt al bl in - (WW w_0 q, w_0W r) - else - match w_compare w_0 bh with - | Eq => - let(q,r):= - double_divn1 w_zdigits w_0 w_WW w_head0 w_add_mul_div w_div21 - w_compare w_sub 1 a bl in - (q, w_0W r) - | Lt => ww_div_gt_aux ah al bh bl - | Gt => (W0,W0) (* cas absurde *) - end - end in [[a]] = [[q]] * [[b]] + [[r]] /\ 0 <= [[r]] < [[b]]). - destruct a as [ |ah al]. simpl in Hgt;omega. - destruct b as [ |bh bl]. simpl in Hpos;omega. - Spec_w_to_Z ah; Spec_w_to_Z al; Spec_w_to_Z bh; Spec_w_to_Z bl. - assert (H:=@spec_eq0 ah);destruct (w_eq0 ah). - simpl ww_to_Z;rewrite H;trivial. simpl in Hgt;rewrite H in Hgt;trivial. - assert ([|bh|] <= 0). - apply beta_lex with (d:=[|al|])(b:=[|bl|]) (beta := wB);zarith. - assert ([|bh|] = 0);zarith. rewrite H1 in Hgt;rewrite H1;simpl in Hgt. - simpl. simpl in Hpos;rewrite H1 in Hpos;simpl in Hpos. - assert (H2:=spec_div_gt Hgt Hpos);destruct (w_div_gt al bl). - repeat rewrite spec_w_0W;simpl;rewrite spec_w_0;simpl;trivial. - clear H. - rewrite spec_compare; case Z.compare_spec; intros Hcmp. - rewrite spec_w_0 in Hcmp. change [[WW bh bl]] with ([|bh|]*wB+[|bl|]). - rewrite <- Hcmp;rewrite Z.mul_0_l;rewrite Z.add_0_l. - simpl in Hpos;rewrite <- Hcmp in Hpos;simpl in Hpos. - assert (H2:= @spec_double_divn1 w w_digits w_zdigits w_0 w_WW w_head0 w_add_mul_div - w_div21 w_compare w_sub w_to_Z spec_to_Z spec_w_zdigits spec_w_0 spec_w_WW spec_head0 - spec_add_mul_div spec_div21 spec_compare spec_sub 1 (WW ah al) bl Hpos). - destruct (double_divn1 w_zdigits w_0 w_WW w_head0 w_add_mul_div w_div21 - w_compare w_sub 1 - (WW ah al) bl). - rewrite spec_w_0W;unfold ww_to_Z;trivial. - apply spec_ww_div_gt_aux;trivial. rewrite spec_w_0 in Hcmp;trivial. - rewrite spec_w_0 in Hcmp;exfalso;omega. - Qed. - - Lemma spec_ww_mod_gt_aux_eq : forall ah al bh bl, - ww_mod_gt_aux ah al bh bl = snd (ww_div_gt_aux ah al bh bl). - Proof. - intros ah al bh bl. unfold ww_mod_gt_aux, ww_div_gt_aux. - case w_compare; auto. - case w_div32; auto. - Qed. - - Lemma spec_ww_mod_gt_aux : forall ah al bh bl, - [[WW ah al]] > [[WW bh bl]] -> - 0 < [|bh|] -> - [[ww_mod_gt_aux ah al bh bl]] = [[WW ah al]] mod [[WW bh bl]]. - Proof. - intros. rewrite spec_ww_mod_gt_aux_eq;trivial. - assert (H3 := spec_ww_div_gt_aux ah al bl H H0). - destruct (ww_div_gt_aux ah al bh bl) as (q,r);simpl. simpl in H,H3. - destruct H3;apply Zmod_unique with [[q]];zarith. - rewrite H1;ring. - Qed. - - Lemma spec_w_mod_gt_eq : forall a b, [|a|] > [|b|] -> 0 <[|b|] -> - [|w_mod_gt a b|] = [|snd (w_div_gt a b)|]. - Proof. - intros a b Hgt Hpos. - rewrite spec_mod_gt;trivial. - assert (H:=spec_div_gt Hgt Hpos). - destruct (w_div_gt a b) as (q,r);simpl. - rewrite Z.mul_comm in H;destruct H. - symmetry;apply Zmod_unique with [|q|];trivial. - Qed. - - Lemma spec_ww_mod_gt_eq : forall a b, [[a]] > [[b]] -> 0 < [[b]] -> - [[ww_mod_gt a b]] = [[snd (ww_div_gt a b)]]. - Proof. - intros a b Hgt Hpos. - change (ww_mod_gt a b) with - (match a, b with - | W0, _ => W0 - | _, W0 => W0 - | WW ah al, WW bh bl => - if w_eq0 ah then w_0W (w_mod_gt al bl) - else - match w_compare w_0 bh with - | Eq => - w_0W (double_modn1 w_zdigits w_0 w_head0 w_add_mul_div w_div21 - w_compare w_sub 1 a bl) - | Lt => ww_mod_gt_aux ah al bh bl - | Gt => W0 (* cas absurde *) - end end). - change (ww_div_gt a b) with - (match a, b with - | W0, _ => (W0,W0) - | _, W0 => (W0,W0) - | WW ah al, WW bh bl => - if w_eq0 ah then - let (q,r) := w_div_gt al bl in - (WW w_0 q, w_0W r) - else - match w_compare w_0 bh with - | Eq => - let(q,r):= - double_divn1 w_zdigits w_0 w_WW w_head0 w_add_mul_div w_div21 - w_compare w_sub 1 a bl in - (q, w_0W r) - | Lt => ww_div_gt_aux ah al bh bl - | Gt => (W0,W0) (* cas absurde *) - end - end). - destruct a as [ |ah al];trivial. - destruct b as [ |bh bl];trivial. - Spec_w_to_Z ah; Spec_w_to_Z al; Spec_w_to_Z bh; Spec_w_to_Z bl. - assert (H:=@spec_eq0 ah);destruct (w_eq0 ah). - simpl in Hgt;rewrite H in Hgt;trivial. - assert ([|bh|] <= 0). - apply beta_lex with (d:=[|al|])(b:=[|bl|]) (beta := wB);zarith. - assert ([|bh|] = 0);zarith. rewrite H1 in Hgt;simpl in Hgt. - simpl in Hpos;rewrite H1 in Hpos;simpl in Hpos. - rewrite spec_w_0W;rewrite spec_w_mod_gt_eq;trivial. - destruct (w_div_gt al bl);simpl;rewrite spec_w_0W;trivial. - clear H. - rewrite spec_compare; case Z.compare_spec; intros H2. - rewrite (@spec_double_modn1_aux w w_zdigits w_0 w_WW w_head0 w_add_mul_div - w_div21 w_compare w_sub w_to_Z spec_w_0 spec_compare 1 (WW ah al) bl). - destruct (double_divn1 w_zdigits w_0 w_WW w_head0 w_add_mul_div w_div21 w_compare w_sub 1 - (WW ah al) bl);simpl;trivial. - rewrite spec_ww_mod_gt_aux_eq;trivial;symmetry;trivial. - trivial. - Qed. - - Lemma spec_ww_mod_gt : forall a b, [[a]] > [[b]] -> 0 < [[b]] -> - [[ww_mod_gt a b]] = [[a]] mod [[b]]. - Proof. - intros a b Hgt Hpos. - assert (H:= spec_ww_div_gt a b Hgt Hpos). - rewrite (spec_ww_mod_gt_eq a b Hgt Hpos). - destruct (ww_div_gt a b)as(q,r);destruct H. - apply Zmod_unique with[[q]];simpl;trivial. - rewrite Z.mul_comm;trivial. - Qed. - - Lemma Zis_gcd_mod : forall a b d, - 0 < b -> Zis_gcd b (a mod b) d -> Zis_gcd a b d. - Proof. - intros a b d H H1; apply Zis_gcd_for_euclid with (a/b). - pattern a at 1;rewrite (Z_div_mod_eq a b). - ring_simplify (b * (a / b) + a mod b - a / b * b);trivial. zarith. - Qed. - - Lemma spec_ww_gcd_gt_aux_body : - forall ah al bh bl n cont, - [[WW bh bl]] <= 2^n -> - [[WW ah al]] > [[WW bh bl]] -> - (forall xh xl yh yl, - [[WW xh xl]] > [[WW yh yl]] -> [[WW yh yl]] <= 2^(n-1) -> - Zis_gcd [[WW xh xl]] [[WW yh yl]] [[cont xh xl yh yl]]) -> - Zis_gcd [[WW ah al]] [[WW bh bl]] [[ww_gcd_gt_body cont ah al bh bl]]. - Proof. - intros ah al bh bl n cont Hlog Hgt Hcont. - change (ww_gcd_gt_body cont ah al bh bl) with (match w_compare w_0 bh with - | Eq => - match w_compare w_0 bl with - | Eq => WW ah al (* normalement n'arrive pas si forme normale *) - | Lt => - let m := double_modn1 w_zdigits w_0 w_head0 w_add_mul_div w_div21 - w_compare w_sub 1 (WW ah al) bl in - WW w_0 (w_gcd_gt bl m) - | Gt => W0 (* absurde *) - end - | Lt => - let m := ww_mod_gt_aux ah al bh bl in - match m with - | W0 => WW bh bl - | WW mh ml => - match w_compare w_0 mh with - | Eq => - match w_compare w_0 ml with - | Eq => WW bh bl - | _ => - let r := double_modn1 w_zdigits w_0 w_head0 w_add_mul_div w_div21 - w_compare w_sub 1 (WW bh bl) ml in - WW w_0 (w_gcd_gt ml r) - end - | Lt => - let r := ww_mod_gt_aux bh bl mh ml in - match r with - | W0 => m - | WW rh rl => cont mh ml rh rl - end - | Gt => W0 (* absurde *) - end - end - | Gt => W0 (* absurde *) - end). - rewrite spec_compare, spec_w_0. - case Z.compare_spec; intros Hbh. - simpl ww_to_Z in *. rewrite <- Hbh. - rewrite Z.mul_0_l;rewrite Z.add_0_l. - rewrite spec_compare, spec_w_0. - case Z.compare_spec; intros Hbl. - rewrite <- Hbl;apply Zis_gcd_0. - simpl;rewrite spec_w_0;rewrite Z.mul_0_l;rewrite Z.add_0_l. - apply Zis_gcd_mod;zarith. - change ([|ah|] * wB + [|al|]) with (double_to_Z w_digits w_to_Z 1 (WW ah al)). - rewrite <- (@spec_double_modn1 w w_digits w_zdigits w_0 w_WW w_head0 w_add_mul_div - w_div21 w_compare w_sub w_to_Z spec_to_Z spec_w_zdigits spec_w_0 spec_w_WW spec_head0 spec_add_mul_div - spec_div21 spec_compare spec_sub 1 (WW ah al) bl Hbl). - apply spec_gcd_gt. - rewrite (@spec_double_modn1 w w_digits w_zdigits w_0 w_WW); trivial. - apply Z.lt_gt;match goal with | |- ?x mod ?y < ?y => - destruct (Z_mod_lt x y);zarith end. - Spec_w_to_Z bl;exfalso;omega. - assert (H:= spec_ww_mod_gt_aux _ _ _ Hgt Hbh). - assert (H2 : 0 < [[WW bh bl]]). - simpl;Spec_w_to_Z bl. apply Z.lt_le_trans with ([|bh|]*wB);zarith. - apply Z.mul_pos_pos;zarith. - apply Zis_gcd_mod;trivial. rewrite <- H. - simpl in *;destruct (ww_mod_gt_aux ah al bh bl) as [ |mh ml]. - simpl;apply Zis_gcd_0;zarith. - rewrite spec_compare, spec_w_0; case Z.compare_spec; intros Hmh. - simpl;rewrite <- Hmh;simpl. - rewrite spec_compare, spec_w_0; case Z.compare_spec; intros Hml. - rewrite <- Hml;simpl;apply Zis_gcd_0. - simpl; rewrite spec_w_0; simpl. - apply Zis_gcd_mod;zarith. - change ([|bh|] * wB + [|bl|]) with (double_to_Z w_digits w_to_Z 1 (WW bh bl)). - rewrite <- (@spec_double_modn1 w w_digits w_zdigits w_0 w_WW w_head0 w_add_mul_div - w_div21 w_compare w_sub w_to_Z spec_to_Z spec_w_zdigits spec_w_0 spec_w_WW spec_head0 spec_add_mul_div - spec_div21 spec_compare spec_sub 1 (WW bh bl) ml Hml). - apply spec_gcd_gt. - rewrite (@spec_double_modn1 w w_digits w_zdigits w_0 w_WW); trivial. - apply Z.lt_gt;match goal with | |- ?x mod ?y < ?y => - destruct (Z_mod_lt x y);zarith end. - Spec_w_to_Z ml;exfalso;omega. - assert ([[WW bh bl]] > [[WW mh ml]]). - rewrite H;simpl; apply Z.lt_gt;match goal with | |- ?x mod ?y < ?y => - destruct (Z_mod_lt x y);zarith end. - assert (H1:= spec_ww_mod_gt_aux _ _ _ H0 Hmh). - assert (H3 : 0 < [[WW mh ml]]). - simpl;Spec_w_to_Z ml. apply Z.lt_le_trans with ([|mh|]*wB);zarith. - apply Z.mul_pos_pos;zarith. - apply Zis_gcd_mod;zarith. simpl in *;rewrite <- H1. - destruct (ww_mod_gt_aux bh bl mh ml) as [ |rh rl]. simpl; apply Zis_gcd_0. - simpl;apply Hcont. simpl in H1;rewrite H1. - apply Z.lt_gt;match goal with | |- ?x mod ?y < ?y => - destruct (Z_mod_lt x y);zarith end. - apply Z.le_trans with (2^n/2). - apply Zdiv_le_lower_bound;zarith. - apply Z.le_trans with ([|bh|] * wB + [|bl|]);zarith. - assert (H3' := Z_div_mod_eq [[WW bh bl]] [[WW mh ml]] (Z.lt_gt _ _ H3)). - assert (H4 : 0 <= [[WW bh bl]]/[[WW mh ml]]). - apply Z.ge_le;apply Z_div_ge0;zarith. simpl in *;rewrite H1. - pattern ([|bh|] * wB + [|bl|]) at 2;rewrite H3'. - Z.le_elim H4. - assert (H6' : [[WW bh bl]] mod [[WW mh ml]] = - [[WW bh bl]] - [[WW mh ml]] * ([[WW bh bl]]/[[WW mh ml]])). - simpl;pattern ([|bh|] * wB + [|bl|]) at 2;rewrite H3';ring. simpl in H6'. - assert ([[WW mh ml]] <= [[WW mh ml]] * ([[WW bh bl]]/[[WW mh ml]])). - simpl;pattern ([|mh|]*wB+[|ml|]) at 1;rewrite <- Z.mul_1_r;zarith. - simpl in *;assert (H8 := Z_mod_lt [[WW bh bl]] [[WW mh ml]]);simpl in H8; - zarith. - assert (H8 := Z_mod_lt [[WW bh bl]] [[WW mh ml]]);simpl in *;zarith. - rewrite <- H4 in H3';rewrite Z.mul_0_r in H3';simpl in H3';zarith. - pattern n at 1;replace n with (n-1+1);try ring. - rewrite Zpower_exp;zarith. change (2^1) with 2. - rewrite Z_div_mult;zarith. - assert (2^1 <= 2^n). change (2^1) with 2;zarith. - assert (H7 := @Zpower_le_monotone_inv 2 1 n);zarith. - Spec_w_to_Z mh;exfalso;zarith. - Spec_w_to_Z bh;exfalso;zarith. - Qed. - - Lemma spec_ww_gcd_gt_aux : - forall p cont n, - (forall xh xl yh yl, - [[WW xh xl]] > [[WW yh yl]] -> - [[WW yh yl]] <= 2^n -> - Zis_gcd [[WW xh xl]] [[WW yh yl]] [[cont xh xl yh yl]]) -> - forall ah al bh bl , [[WW ah al]] > [[WW bh bl]] -> - [[WW bh bl]] <= 2^(Zpos p + n) -> - Zis_gcd [[WW ah al]] [[WW bh bl]] - [[ww_gcd_gt_aux p cont ah al bh bl]]. - Proof. - induction p;intros cont n Hcont ah al bh bl Hgt Hs;simpl ww_gcd_gt_aux. - assert (0 < Zpos p). unfold Z.lt;reflexivity. - apply spec_ww_gcd_gt_aux_body with (n := Zpos (xI p) + n); - trivial;rewrite Pos2Z.inj_xI. - intros. apply IHp with (n := Zpos p + n);zarith. - intros. apply IHp with (n := n );zarith. - apply Z.le_trans with (2 ^ (2* Zpos p + 1+ n -1));zarith. - apply Z.pow_le_mono_r;zarith. - assert (0 < Zpos p). unfold Z.lt;reflexivity. - apply spec_ww_gcd_gt_aux_body with (n := Zpos (xO p) + n );trivial. - rewrite (Pos2Z.inj_xO p). - intros. apply IHp with (n := Zpos p + n - 1);zarith. - intros. apply IHp with (n := n -1 );zarith. - intros;apply Hcont;zarith. - apply Z.le_trans with (2^(n-1));zarith. - apply Z.pow_le_mono_r;zarith. - apply Z.le_trans with (2 ^ (Zpos p + n -1));zarith. - apply Z.pow_le_mono_r;zarith. - apply Z.le_trans with (2 ^ (2*Zpos p + n -1));zarith. - apply Z.pow_le_mono_r;zarith. - apply spec_ww_gcd_gt_aux_body with (n := n+1);trivial. - rewrite Z.add_comm;trivial. - ring_simplify (n + 1 - 1);trivial. - Qed. - -End DoubleDivGt. - -Section DoubleDiv. - - Variable w : Type. - Variable w_digits : positive. - Variable ww_1 : zn2z w. - Variable ww_compare : zn2z w -> zn2z w -> comparison. - - Variable ww_div_gt : zn2z w -> zn2z w -> zn2z w * zn2z w. - Variable ww_mod_gt : zn2z w -> zn2z w -> zn2z w. - - Definition ww_div a b := - match ww_compare a b with - | Gt => ww_div_gt a b - | Eq => (ww_1, W0) - | Lt => (W0, a) - end. - - Definition ww_mod a b := - match ww_compare a b with - | Gt => ww_mod_gt a b - | Eq => W0 - | Lt => a - end. - - Variable w_to_Z : w -> Z. - Notation wB := (base w_digits). - Notation wwB := (base (ww_digits w_digits)). - Notation "[| x |]" := (w_to_Z x) (at level 0, x at level 99). - Notation "[[ x ]]" := (ww_to_Z w_digits w_to_Z x)(at level 0, x at level 99). - Variable spec_to_Z : forall x, 0 <= [|x|] < wB. - Variable spec_ww_1 : [[ww_1]] = 1. - Variable spec_ww_compare : forall x y, - ww_compare x y = Z.compare [[x]] [[y]]. - Variable spec_ww_div_gt : forall a b, [[a]] > [[b]] -> 0 < [[b]] -> - let (q,r) := ww_div_gt a b in - [[a]] = [[q]] * [[b]] + [[r]] /\ - 0 <= [[r]] < [[b]]. - Variable spec_ww_mod_gt : forall a b, [[a]] > [[b]] -> 0 < [[b]] -> - [[ww_mod_gt a b]] = [[a]] mod [[b]]. - - Ltac Spec_w_to_Z x := - let H:= fresh "HH" in - assert (H:= spec_to_Z x). - - Ltac Spec_ww_to_Z x := - let H:= fresh "HH" in - assert (H:= spec_ww_to_Z w_digits w_to_Z spec_to_Z x). - - Lemma spec_ww_div : forall a b, 0 < [[b]] -> - let (q,r) := ww_div a b in - [[a]] = [[q]] * [[b]] + [[r]] /\ - 0 <= [[r]] < [[b]]. - Proof. - intros a b Hpos;unfold ww_div. - rewrite spec_ww_compare; case Z.compare_spec; intros. - simpl;rewrite spec_ww_1;split;zarith. - simpl;split;[ring|Spec_ww_to_Z a;zarith]. - apply spec_ww_div_gt;auto with zarith. - Qed. - - Lemma spec_ww_mod : forall a b, 0 < [[b]] -> - [[ww_mod a b]] = [[a]] mod [[b]]. - Proof. - intros a b Hpos;unfold ww_mod. - rewrite spec_ww_compare; case Z.compare_spec; intros. - simpl;apply Zmod_unique with 1;try rewrite H;zarith. - Spec_ww_to_Z a;symmetry;apply Zmod_small;zarith. - apply spec_ww_mod_gt;auto with zarith. - Qed. - - - Variable w_0 : w. - Variable w_1 : w. - Variable w_compare : w -> w -> comparison. - Variable w_eq0 : w -> bool. - Variable w_gcd_gt : w -> w -> w. - Variable _ww_digits : positive. - Variable spec_ww_digits_ : _ww_digits = xO w_digits. - Variable ww_gcd_gt_fix : - positive -> (w -> w -> w -> w -> zn2z w) -> - w -> w -> w -> w -> zn2z w. - - Variable spec_w_0 : [|w_0|] = 0. - Variable spec_w_1 : [|w_1|] = 1. - Variable spec_compare : - forall x y, w_compare x y = Z.compare [|x|] [|y|]. - Variable spec_eq0 : forall x, w_eq0 x = true -> [|x|] = 0. - Variable spec_gcd_gt : forall a b, [|a|] > [|b|] -> - Zis_gcd [|a|] [|b|] [|w_gcd_gt a b|]. - Variable spec_gcd_gt_fix : - forall p cont n, - (forall xh xl yh yl, - [[WW xh xl]] > [[WW yh yl]] -> - [[WW yh yl]] <= 2^n -> - Zis_gcd [[WW xh xl]] [[WW yh yl]] [[cont xh xl yh yl]]) -> - forall ah al bh bl , [[WW ah al]] > [[WW bh bl]] -> - [[WW bh bl]] <= 2^(Zpos p + n) -> - Zis_gcd [[WW ah al]] [[WW bh bl]] - [[ww_gcd_gt_fix p cont ah al bh bl]]. - - Definition gcd_cont (xh xl yh yl:w) := - match w_compare w_1 yl with - | Eq => ww_1 - | _ => WW xh xl - end. - - Lemma spec_gcd_cont : forall xh xl yh yl, - [[WW xh xl]] > [[WW yh yl]] -> - [[WW yh yl]] <= 1 -> - Zis_gcd [[WW xh xl]] [[WW yh yl]] [[gcd_cont xh xl yh yl]]. - Proof. - intros xh xl yh yl Hgt' Hle. simpl in Hle. - assert ([|yh|] = 0). - change 1 with (0*wB+1) in Hle. - assert (0 <= 1 < wB). split;zarith. apply wB_pos. - assert (H1:= beta_lex _ _ _ _ _ Hle (spec_to_Z yl) H). - Spec_w_to_Z yh;zarith. - unfold gcd_cont; rewrite spec_compare, spec_w_1. - case Z.compare_spec; intros Hcmpy. - simpl;rewrite H;simpl; - rewrite spec_ww_1;rewrite <- Hcmpy;apply Zis_gcd_mod;zarith. - rewrite <- (Zmod_unique ([|xh|]*wB+[|xl|]) 1 ([|xh|]*wB+[|xl|]) 0);zarith. - rewrite H in Hle; exfalso;zarith. - assert (H0 : [|yl|] = 0) by (Spec_w_to_Z yl;zarith). - simpl. rewrite H0, H;simpl;apply Zis_gcd_0;trivial. - Qed. - - - Variable cont : w -> w -> w -> w -> zn2z w. - Variable spec_cont : forall xh xl yh yl, - [[WW xh xl]] > [[WW yh yl]] -> - [[WW yh yl]] <= 1 -> - Zis_gcd [[WW xh xl]] [[WW yh yl]] [[cont xh xl yh yl]]. - - Definition ww_gcd_gt a b := - match a, b with - | W0, _ => b - | _, W0 => a - | WW ah al, WW bh bl => - if w_eq0 ah then (WW w_0 (w_gcd_gt al bl)) - else ww_gcd_gt_fix _ww_digits cont ah al bh bl - end. - - Definition ww_gcd a b := - Eval lazy beta delta [ww_gcd_gt] in - match ww_compare a b with - | Gt => ww_gcd_gt a b - | Eq => a - | Lt => ww_gcd_gt b a - end. - - Lemma spec_ww_gcd_gt : forall a b, [[a]] > [[b]] -> - Zis_gcd [[a]] [[b]] [[ww_gcd_gt a b]]. - Proof. - intros a b Hgt;unfold ww_gcd_gt. - destruct a as [ |ah al]. simpl;apply Zis_gcd_sym;apply Zis_gcd_0. - destruct b as [ |bh bl]. simpl;apply Zis_gcd_0. - simpl in Hgt. generalize (@spec_eq0 ah);destruct (w_eq0 ah);intros. - simpl;rewrite H in Hgt;trivial;rewrite H;trivial;rewrite spec_w_0;simpl. - assert ([|bh|] <= 0). - apply beta_lex with (d:=[|al|])(b:=[|bl|]) (beta := wB);zarith. - Spec_w_to_Z bh;assert ([|bh|] = 0);zarith. rewrite H1 in Hgt;simpl in Hgt. - rewrite H1;simpl;auto. clear H. - apply spec_gcd_gt_fix with (n:= 0);trivial. - rewrite Z.add_0_r;rewrite spec_ww_digits_. - change (2 ^ Zpos (xO w_digits)) with wwB. Spec_ww_to_Z (WW bh bl);zarith. - Qed. - - Lemma spec_ww_gcd : forall a b, Zis_gcd [[a]] [[b]] [[ww_gcd a b]]. - Proof. - intros a b. - change (ww_gcd a b) with - (match ww_compare a b with - | Gt => ww_gcd_gt a b - | Eq => a - | Lt => ww_gcd_gt b a - end). - rewrite spec_ww_compare; case Z.compare_spec; intros Hcmp. - Spec_ww_to_Z b;rewrite Hcmp. - apply Zis_gcd_for_euclid with 1;zarith. - ring_simplify ([[b]] - 1 * [[b]]). apply Zis_gcd_0;zarith. - apply Zis_gcd_sym;apply spec_ww_gcd_gt;zarith. - apply spec_ww_gcd_gt;zarith. - Qed. - -End DoubleDiv. - diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleDivn1.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleDivn1.v deleted file mode 100644 index 195527dd5b..0000000000 --- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleDivn1.v +++ /dev/null @@ -1,519 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) -(* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) -(************************************************************************) - -Set Implicit Arguments. - -Require Import ZArith Ndigits. -Require Import BigNumPrelude. -Require Import DoubleType. -Require Import DoubleBase. - -Local Open Scope Z_scope. - -Local Infix "<<" := Pos.shiftl_nat (at level 30). - -Section GENDIVN1. - - Variable w : Type. - Variable w_digits : positive. - Variable w_zdigits : w. - Variable w_0 : w. - Variable w_WW : w -> w -> zn2z w. - Variable w_head0 : w -> w. - Variable w_add_mul_div : w -> w -> w -> w. - Variable w_div21 : w -> w -> w -> w * w. - Variable w_compare : w -> w -> comparison. - Variable w_sub : w -> w -> w. - - - - (* ** For proofs ** *) - Variable w_to_Z : w -> Z. - - Notation wB := (base w_digits). - - Notation "[| x |]" := (w_to_Z x) (at level 0, x at level 99). - Notation "[! n | x !]" := (double_to_Z w_digits w_to_Z n x) - (at level 0, x at level 99). - Notation "[[ x ]]" := (zn2z_to_Z wB w_to_Z x) (at level 0, x at level 99). - - Variable spec_to_Z : forall x, 0 <= [| x |] < wB. - Variable spec_w_zdigits: [|w_zdigits|] = Zpos w_digits. - Variable spec_0 : [|w_0|] = 0. - Variable spec_WW : forall h l, [[w_WW h l]] = [|h|] * wB + [|l|]. - Variable spec_head0 : forall x, 0 < [|x|] -> - wB/ 2 <= 2 ^ [|w_head0 x|] * [|x|] < wB. - Variable spec_add_mul_div : forall x y p, - [|p|] <= Zpos w_digits -> - [| w_add_mul_div p x y |] = - ([|x|] * (2 ^ [|p|]) + - [|y|] / (2 ^ ((Zpos w_digits) - [|p|]))) mod wB. - Variable spec_div21 : forall a1 a2 b, - wB/2 <= [|b|] -> - [|a1|] < [|b|] -> - let (q,r) := w_div21 a1 a2 b in - [|a1|] *wB+ [|a2|] = [|q|] * [|b|] + [|r|] /\ - 0 <= [|r|] < [|b|]. - Variable spec_compare : - forall x y, w_compare x y = Z.compare [|x|] [|y|]. - Variable spec_sub: forall x y, - [|w_sub x y|] = ([|x|] - [|y|]) mod wB. - - - - Section DIVAUX. - Variable b2p : w. - Variable b2p_le : wB/2 <= [|b2p|]. - - Definition double_divn1_0_aux n (divn1: w -> word w n -> word w n * w) r h := - let (hh,hl) := double_split w_0 n h in - let (qh,rh) := divn1 r hh in - let (ql,rl) := divn1 rh hl in - (double_WW w_WW n qh ql, rl). - - Fixpoint double_divn1_0 (n:nat) : w -> word w n -> word w n * w := - match n return w -> word w n -> word w n * w with - | O => fun r x => w_div21 r x b2p - | S n => double_divn1_0_aux n (double_divn1_0 n) - end. - - Lemma spec_split : forall (n : nat) (x : zn2z (word w n)), - let (h, l) := double_split w_0 n x in - [!S n | x!] = [!n | h!] * double_wB w_digits n + [!n | l!]. - Proof (spec_double_split w_0 w_digits w_to_Z spec_0). - - Lemma spec_double_divn1_0 : forall n r a, - [|r|] < [|b2p|] -> - let (q,r') := double_divn1_0 n r a in - [|r|] * double_wB w_digits n + [!n|a!] = [!n|q!] * [|b2p|] + [|r'|] /\ - 0 <= [|r'|] < [|b2p|]. - Proof. - induction n;intros. - exact (spec_div21 a b2p_le H). - simpl (double_divn1_0 (S n) r a); unfold double_divn1_0_aux. - assert (H1 := spec_split n a);destruct (double_split w_0 n a) as (hh,hl). - rewrite H1. - assert (H2 := IHn r hh H);destruct (double_divn1_0 n r hh) as (qh,rh). - destruct H2. - assert ([|rh|] < [|b2p|]). omega. - assert (H4 := IHn rh hl H3);destruct (double_divn1_0 n rh hl) as (ql,rl). - destruct H4;split;trivial. - rewrite spec_double_WW;trivial. - rewrite <- double_wB_wwB. - rewrite Z.mul_assoc;rewrite Z.add_assoc;rewrite <- Z.mul_add_distr_r. - rewrite H0;rewrite Z.mul_add_distr_r;rewrite <- Z.add_assoc. - rewrite H4;ring. - Qed. - - Definition double_modn1_0_aux n (modn1:w -> word w n -> w) r h := - let (hh,hl) := double_split w_0 n h in modn1 (modn1 r hh) hl. - - Fixpoint double_modn1_0 (n:nat) : w -> word w n -> w := - match n return w -> word w n -> w with - | O => fun r x => snd (w_div21 r x b2p) - | S n => double_modn1_0_aux n (double_modn1_0 n) - end. - - Lemma spec_double_modn1_0 : forall n r x, - double_modn1_0 n r x = snd (double_divn1_0 n r x). - Proof. - induction n;simpl;intros;trivial. - unfold double_modn1_0_aux, double_divn1_0_aux. - destruct (double_split w_0 n x) as (hh,hl). - rewrite (IHn r hh). - destruct (double_divn1_0 n r hh) as (qh,rh);simpl. - rewrite IHn. destruct (double_divn1_0 n rh hl);trivial. - Qed. - - Variable p : w. - Variable p_bounded : [|p|] <= Zpos w_digits. - - Lemma spec_add_mul_divp : forall x y, - [| w_add_mul_div p x y |] = - ([|x|] * (2 ^ [|p|]) + - [|y|] / (2 ^ ((Zpos w_digits) - [|p|]))) mod wB. - Proof. - intros;apply spec_add_mul_div;auto. - Qed. - - Definition double_divn1_p_aux n - (divn1 : w -> word w n -> word w n -> word w n * w) r h l := - let (hh,hl) := double_split w_0 n h in - let (lh,ll) := double_split w_0 n l in - let (qh,rh) := divn1 r hh hl in - let (ql,rl) := divn1 rh hl lh in - (double_WW w_WW n qh ql, rl). - - Fixpoint double_divn1_p (n:nat) : w -> word w n -> word w n -> word w n * w := - match n return w -> word w n -> word w n -> word w n * w with - | O => fun r h l => w_div21 r (w_add_mul_div p h l) b2p - | S n => double_divn1_p_aux n (double_divn1_p n) - end. - - Lemma p_lt_double_digits : forall n, [|p|] <= Zpos (w_digits << n). - Proof. - induction n;simpl. trivial. - case (spec_to_Z p); rewrite Pos2Z.inj_xO;auto with zarith. - Qed. - - Lemma spec_double_divn1_p : forall n r h l, - [|r|] < [|b2p|] -> - let (q,r') := double_divn1_p n r h l in - [|r|] * double_wB w_digits n + - ([!n|h!]*2^[|p|] + - [!n|l!] / (2^(Zpos(w_digits << n) - [|p|]))) - mod double_wB w_digits n = [!n|q!] * [|b2p|] + [|r'|] /\ - 0 <= [|r'|] < [|b2p|]. - Proof. - case (spec_to_Z p); intros HH0 HH1. - induction n;intros. - simpl (double_divn1_p 0 r h l). - unfold double_to_Z, double_wB, "<<". - rewrite <- spec_add_mul_divp. - exact (spec_div21 (w_add_mul_div p h l) b2p_le H). - simpl (double_divn1_p (S n) r h l). - unfold double_divn1_p_aux. - assert (H1 := spec_split n h);destruct (double_split w_0 n h) as (hh,hl). - rewrite H1. rewrite <- double_wB_wwB. - assert (H2 := spec_split n l);destruct (double_split w_0 n l) as (lh,ll). - rewrite H2. - replace ([|r|] * (double_wB w_digits n * double_wB w_digits n) + - (([!n|hh!] * double_wB w_digits n + [!n|hl!]) * 2 ^ [|p|] + - ([!n|lh!] * double_wB w_digits n + [!n|ll!]) / - 2^(Zpos (w_digits << (S n)) - [|p|])) mod - (double_wB w_digits n * double_wB w_digits n)) with - (([|r|] * double_wB w_digits n + ([!n|hh!] * 2^[|p|] + - [!n|hl!] / 2^(Zpos (w_digits << n) - [|p|])) mod - double_wB w_digits n) * double_wB w_digits n + - ([!n|hl!] * 2^[|p|] + - [!n|lh!] / 2^(Zpos (w_digits << n) - [|p|])) mod - double_wB w_digits n). - generalize (IHn r hh hl H);destruct (double_divn1_p n r hh hl) as (qh,rh); - intros (H3,H4);rewrite H3. - assert ([|rh|] < [|b2p|]). omega. - replace (([!n|qh!] * [|b2p|] + [|rh|]) * double_wB w_digits n + - ([!n|hl!] * 2 ^ [|p|] + - [!n|lh!] / 2 ^ (Zpos (w_digits << n) - [|p|])) mod - double_wB w_digits n) with - ([!n|qh!] * [|b2p|] *double_wB w_digits n + ([|rh|]*double_wB w_digits n + - ([!n|hl!] * 2 ^ [|p|] + - [!n|lh!] / 2 ^ (Zpos (w_digits << n) - [|p|])) mod - double_wB w_digits n)). 2:ring. - generalize (IHn rh hl lh H0);destruct (double_divn1_p n rh hl lh) as (ql,rl); - intros (H5,H6);rewrite H5. - split;[rewrite spec_double_WW;trivial;ring|trivial]. - assert (Uhh := spec_double_to_Z w_digits w_to_Z spec_to_Z n hh); - unfold double_wB,base in Uhh. - assert (Uhl := spec_double_to_Z w_digits w_to_Z spec_to_Z n hl); - unfold double_wB,base in Uhl. - assert (Ulh := spec_double_to_Z w_digits w_to_Z spec_to_Z n lh); - unfold double_wB,base in Ulh. - assert (Ull := spec_double_to_Z w_digits w_to_Z spec_to_Z n ll); - unfold double_wB,base in Ull. - unfold double_wB,base. - assert (UU:=p_lt_double_digits n). - rewrite Zdiv_shift_r;auto with zarith. - 2:change (Zpos (w_digits << (S n))) - with (2*Zpos (w_digits << n));auto with zarith. - replace (2 ^ (Zpos (w_digits << (S n)) - [|p|])) with - (2^(Zpos (w_digits << n) - [|p|])*2^Zpos (w_digits << n)). - rewrite Zdiv_mult_cancel_r;auto with zarith. - rewrite Z.mul_add_distr_r with (p:= 2^[|p|]). - pattern ([!n|hl!] * 2^[|p|]) at 2; - rewrite (shift_unshift_mod (Zpos(w_digits << n))([|p|])([!n|hl!])); - auto with zarith. - rewrite Z.add_assoc. - replace - ([!n|hh!] * 2^Zpos (w_digits << n)* 2^[|p|] + - ([!n|hl!] / 2^(Zpos (w_digits << n)-[|p|])* - 2^Zpos(w_digits << n))) - with - (([!n|hh!] *2^[|p|] + double_to_Z w_digits w_to_Z n hl / - 2^(Zpos (w_digits << n)-[|p|])) - * 2^Zpos(w_digits << n));try (ring;fail). - rewrite <- Z.add_assoc. - rewrite <- (Zmod_shift_r ([|p|]));auto with zarith. - replace - (2 ^ Zpos (w_digits << n) * 2 ^ Zpos (w_digits << n)) with - (2 ^ (Zpos (w_digits << n) + Zpos (w_digits << n))). - rewrite (Zmod_shift_r (Zpos (w_digits << n)));auto with zarith. - replace (2 ^ (Zpos (w_digits << n) + Zpos (w_digits << n))) - with (2^Zpos(w_digits << n) *2^Zpos(w_digits << n)). - rewrite (Z.mul_comm (([!n|hh!] * 2 ^ [|p|] + - [!n|hl!] / 2 ^ (Zpos (w_digits << n) - [|p|])))). - rewrite Zmult_mod_distr_l;auto with zarith. - ring. - rewrite Zpower_exp;auto with zarith. - assert (0 < Zpos (w_digits << n)). unfold Z.lt;reflexivity. - auto with zarith. - apply Z_mod_lt;auto with zarith. - rewrite Zpower_exp;auto with zarith. - split;auto with zarith. - apply Zdiv_lt_upper_bound;auto with zarith. - rewrite <- Zpower_exp;auto with zarith. - replace ([|p|] + (Zpos (w_digits << n) - [|p|])) with - (Zpos(w_digits << n));auto with zarith. - rewrite <- Zpower_exp;auto with zarith. - replace (Zpos (w_digits << (S n)) - [|p|]) with - (Zpos (w_digits << n) - [|p|] + - Zpos (w_digits << n));trivial. - change (Zpos (w_digits << (S n))) with - (2*Zpos (w_digits << n)). ring. - Qed. - - Definition double_modn1_p_aux n (modn1 : w -> word w n -> word w n -> w) r h l:= - let (hh,hl) := double_split w_0 n h in - let (lh,ll) := double_split w_0 n l in - modn1 (modn1 r hh hl) hl lh. - - Fixpoint double_modn1_p (n:nat) : w -> word w n -> word w n -> w := - match n return w -> word w n -> word w n -> w with - | O => fun r h l => snd (w_div21 r (w_add_mul_div p h l) b2p) - | S n => double_modn1_p_aux n (double_modn1_p n) - end. - - Lemma spec_double_modn1_p : forall n r h l , - double_modn1_p n r h l = snd (double_divn1_p n r h l). - Proof. - induction n;simpl;intros;trivial. - unfold double_modn1_p_aux, double_divn1_p_aux. - destruct(double_split w_0 n h)as(hh,hl);destruct(double_split w_0 n l) as (lh,ll). - rewrite (IHn r hh hl);destruct (double_divn1_p n r hh hl) as (qh,rh). - rewrite IHn;simpl;destruct (double_divn1_p n rh hl lh);trivial. - Qed. - - End DIVAUX. - - Fixpoint high (n:nat) : word w n -> w := - match n return word w n -> w with - | O => fun a => a - | S n => - fun (a:zn2z (word w n)) => - match a with - | W0 => w_0 - | WW h l => high n h - end - end. - - Lemma spec_double_digits:forall n, Zpos w_digits <= Zpos (w_digits << n). - Proof. - induction n;simpl;auto with zarith. - change (Zpos (xO (w_digits << n))) with - (2*Zpos (w_digits << n)). - assert (0 < Zpos w_digits) by reflexivity. - auto with zarith. - Qed. - - Lemma spec_high : forall n (x:word w n), - [|high n x|] = [!n|x!] / 2^(Zpos (w_digits << n) - Zpos w_digits). - Proof. - induction n;intros. - unfold high,double_to_Z. rewrite Pshiftl_nat_0. - replace (Zpos w_digits - Zpos w_digits) with 0;try ring. - simpl. rewrite <- (Zdiv_unique [|x|] 1 [|x|] 0);auto with zarith. - assert (U2 := spec_double_digits n). - assert (U3 : 0 < Zpos w_digits). exact (eq_refl Lt). - destruct x;unfold high;fold high. - unfold double_to_Z,zn2z_to_Z;rewrite spec_0. - rewrite Zdiv_0_l;trivial. - assert (U0 := spec_double_to_Z w_digits w_to_Z spec_to_Z n w0); - assert (U1 := spec_double_to_Z w_digits w_to_Z spec_to_Z n w1). - simpl [!S n|WW w0 w1!]. - unfold double_wB,base;rewrite Zdiv_shift_r;auto with zarith. - replace (2 ^ (Zpos (w_digits << (S n)) - Zpos w_digits)) with - (2^(Zpos (w_digits << n) - Zpos w_digits) * - 2^Zpos (w_digits << n)). - rewrite Zdiv_mult_cancel_r;auto with zarith. - rewrite <- Zpower_exp;auto with zarith. - replace (Zpos (w_digits << n) - Zpos w_digits + - Zpos (w_digits << n)) with - (Zpos (w_digits << (S n)) - Zpos w_digits);trivial. - change (Zpos (w_digits << (S n))) with - (2*Zpos (w_digits << n));ring. - change (Zpos (w_digits << (S n))) with - (2*Zpos (w_digits << n)); auto with zarith. - Qed. - - Definition double_divn1 (n:nat) (a:word w n) (b:w) := - let p := w_head0 b in - match w_compare p w_0 with - | Gt => - let b2p := w_add_mul_div p b w_0 in - let ha := high n a in - let k := w_sub w_zdigits p in - let lsr_n := w_add_mul_div k w_0 in - let r0 := w_add_mul_div p w_0 ha in - let (q,r) := double_divn1_p b2p p n r0 a (double_0 w_0 n) in - (q, lsr_n r) - | _ => double_divn1_0 b n w_0 a - end. - - Lemma spec_double_divn1 : forall n a b, - 0 < [|b|] -> - let (q,r) := double_divn1 n a b in - [!n|a!] = [!n|q!] * [|b|] + [|r|] /\ - 0 <= [|r|] < [|b|]. - Proof. - intros n a b H. unfold double_divn1. - case (spec_head0 H); intros H0 H1. - case (spec_to_Z (w_head0 b)); intros HH1 HH2. - rewrite spec_compare; case Z.compare_spec; - rewrite spec_0; intros H2; auto with zarith. - assert (Hv1: wB/2 <= [|b|]). - generalize H0; rewrite H2; rewrite Z.pow_0_r; - rewrite Z.mul_1_l; auto. - assert (Hv2: [|w_0|] < [|b|]). - rewrite spec_0; auto. - generalize (spec_double_divn1_0 Hv1 n a Hv2). - rewrite spec_0;rewrite Z.mul_0_l; rewrite Z.add_0_l; auto. - contradict H2; auto with zarith. - assert (HHHH : 0 < [|w_head0 b|]); auto with zarith. - assert ([|w_head0 b|] < Zpos w_digits). - case (Z.le_gt_cases (Zpos w_digits) [|w_head0 b|]); auto; intros HH. - assert (2 ^ [|w_head0 b|] < wB). - apply Z.le_lt_trans with (2 ^ [|w_head0 b|] * [|b|]);auto with zarith. - replace (2 ^ [|w_head0 b|]) with (2^[|w_head0 b|] * 1);try (ring;fail). - apply Z.mul_le_mono_nonneg;auto with zarith. - assert (wB <= 2^[|w_head0 b|]). - unfold base;apply Zpower_le_monotone;auto with zarith. omega. - assert ([|w_add_mul_div (w_head0 b) b w_0|] = - 2 ^ [|w_head0 b|] * [|b|]). - rewrite (spec_add_mul_div b w_0); auto with zarith. - rewrite spec_0;rewrite Zdiv_0_l; try omega. - rewrite Z.add_0_r; rewrite Z.mul_comm. - rewrite Zmod_small; auto with zarith. - assert (H5 := spec_to_Z (high n a)). - assert - ([|w_add_mul_div (w_head0 b) w_0 (high n a)|] - <[|w_add_mul_div (w_head0 b) b w_0|]). - rewrite H4. - rewrite spec_add_mul_div;auto with zarith. - rewrite spec_0;rewrite Z.mul_0_l;rewrite Z.add_0_l. - assert (([|high n a|]/2^(Zpos w_digits - [|w_head0 b|])) < wB). - apply Zdiv_lt_upper_bound;auto with zarith. - apply Z.lt_le_trans with wB;auto with zarith. - pattern wB at 1;replace wB with (wB*1);try ring. - apply Z.mul_le_mono_nonneg;auto with zarith. - assert (H6 := Z.pow_pos_nonneg 2 (Zpos w_digits - [|w_head0 b|])); - auto with zarith. - rewrite Zmod_small;auto with zarith. - apply Zdiv_lt_upper_bound;auto with zarith. - apply Z.lt_le_trans with wB;auto with zarith. - apply Z.le_trans with (2 ^ [|w_head0 b|] * [|b|] * 2). - rewrite <- wB_div_2; try omega. - apply Z.mul_le_mono_nonneg;auto with zarith. - pattern 2 at 1;rewrite <- Z.pow_1_r. - apply Zpower_le_monotone;split;auto with zarith. - rewrite <- H4 in H0. - assert (Hb3: [|w_head0 b|] <= Zpos w_digits); auto with zarith. - assert (H7:= spec_double_divn1_p H0 Hb3 n a (double_0 w_0 n) H6). - destruct (double_divn1_p (w_add_mul_div (w_head0 b) b w_0) (w_head0 b) n - (w_add_mul_div (w_head0 b) w_0 (high n a)) a - (double_0 w_0 n)) as (q,r). - assert (U:= spec_double_digits n). - rewrite spec_double_0 in H7;trivial;rewrite Zdiv_0_l in H7. - rewrite Z.add_0_r in H7. - rewrite spec_add_mul_div in H7;auto with zarith. - rewrite spec_0 in H7;rewrite Z.mul_0_l in H7;rewrite Z.add_0_l in H7. - assert (([|high n a|] / 2 ^ (Zpos w_digits - [|w_head0 b|])) mod wB - = [!n|a!] / 2^(Zpos (w_digits << n) - [|w_head0 b|])). - rewrite Zmod_small;auto with zarith. - rewrite spec_high. rewrite Zdiv_Zdiv;auto with zarith. - rewrite <- Zpower_exp;auto with zarith. - replace (Zpos (w_digits << n) - Zpos w_digits + - (Zpos w_digits - [|w_head0 b|])) - with (Zpos (w_digits << n) - [|w_head0 b|]);trivial;ring. - assert (H8 := Z.pow_pos_nonneg 2 (Zpos w_digits - [|w_head0 b|]));auto with zarith. - split;auto with zarith. - apply Z.le_lt_trans with ([|high n a|]);auto with zarith. - apply Zdiv_le_upper_bound;auto with zarith. - pattern ([|high n a|]) at 1;rewrite <- Z.mul_1_r. - apply Z.mul_le_mono_nonneg;auto with zarith. - rewrite H8 in H7;unfold double_wB,base in H7. - rewrite <- shift_unshift_mod in H7;auto with zarith. - rewrite H4 in H7. - assert ([|w_add_mul_div (w_sub w_zdigits (w_head0 b)) w_0 r|] - = [|r|]/2^[|w_head0 b|]). - rewrite spec_add_mul_div. - rewrite spec_0;rewrite Z.mul_0_l;rewrite Z.add_0_l. - replace (Zpos w_digits - [|w_sub w_zdigits (w_head0 b)|]) - with ([|w_head0 b|]). - rewrite Zmod_small;auto with zarith. - assert (H9 := spec_to_Z r). - split;auto with zarith. - apply Z.le_lt_trans with ([|r|]);auto with zarith. - apply Zdiv_le_upper_bound;auto with zarith. - pattern ([|r|]) at 1;rewrite <- Z.mul_1_r. - apply Z.mul_le_mono_nonneg;auto with zarith. - assert (H10 := Z.pow_pos_nonneg 2 ([|w_head0 b|]));auto with zarith. - rewrite spec_sub. - rewrite Zmod_small; auto with zarith. - split; auto with zarith. - case (spec_to_Z w_zdigits); auto with zarith. - rewrite spec_sub. - rewrite Zmod_small; auto with zarith. - split; auto with zarith. - case (spec_to_Z w_zdigits); auto with zarith. - case H7; intros H71 H72. - split. - rewrite <- (Z_div_mult [!n|a!] (2^[|w_head0 b|]));auto with zarith. - rewrite H71;rewrite H9. - replace ([!n|q!] * (2 ^ [|w_head0 b|] * [|b|])) - with ([!n|q!] *[|b|] * 2^[|w_head0 b|]); - try (ring;fail). - rewrite Z_div_plus_l;auto with zarith. - assert (H10 := spec_to_Z - (w_add_mul_div (w_sub w_zdigits (w_head0 b)) w_0 r));split; - auto with zarith. - rewrite H9. - apply Zdiv_lt_upper_bound;auto with zarith. - rewrite Z.mul_comm;auto with zarith. - exact (spec_double_to_Z w_digits w_to_Z spec_to_Z n a). - Qed. - - - Definition double_modn1 (n:nat) (a:word w n) (b:w) := - let p := w_head0 b in - match w_compare p w_0 with - | Gt => - let b2p := w_add_mul_div p b w_0 in - let ha := high n a in - let k := w_sub w_zdigits p in - let lsr_n := w_add_mul_div k w_0 in - let r0 := w_add_mul_div p w_0 ha in - let r := double_modn1_p b2p p n r0 a (double_0 w_0 n) in - lsr_n r - | _ => double_modn1_0 b n w_0 a - end. - - Lemma spec_double_modn1_aux : forall n a b, - double_modn1 n a b = snd (double_divn1 n a b). - Proof. - intros n a b;unfold double_divn1,double_modn1. - rewrite spec_compare; case Z.compare_spec; - rewrite spec_0; intros H2; auto with zarith. - apply spec_double_modn1_0. - apply spec_double_modn1_0. - rewrite spec_double_modn1_p. - destruct (double_divn1_p (w_add_mul_div (w_head0 b) b w_0) (w_head0 b) n - (w_add_mul_div (w_head0 b) w_0 (high n a)) a (double_0 w_0 n));simpl;trivial. - Qed. - - Lemma spec_double_modn1 : forall n a b, 0 < [|b|] -> - [|double_modn1 n a b|] = [!n|a!] mod [|b|]. - Proof. - intros n a b H;assert (H1 := spec_double_divn1 n a H). - assert (H2 := spec_double_modn1_aux n a b). - rewrite H2;destruct (double_divn1 n a b) as (q,r). - simpl;apply Zmod_unique with (double_to_Z w_digits w_to_Z n q);auto with zarith. - destruct H1 as (h1,h2);rewrite h1;ring. - Qed. - -End GENDIVN1. diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleLift.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleLift.v deleted file mode 100644 index f65b47c8c4..0000000000 --- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleLift.v +++ /dev/null @@ -1,475 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) -(* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) -(************************************************************************) - -Set Implicit Arguments. - -Require Import ZArith. -Require Import BigNumPrelude. -Require Import DoubleType. -Require Import DoubleBase. - -Local Open Scope Z_scope. - -Section DoubleLift. - Variable w : Type. - Variable w_0 : w. - Variable w_WW : w -> w -> zn2z w. - Variable w_W0 : w -> zn2z w. - Variable w_0W : w -> zn2z w. - Variable w_compare : w -> w -> comparison. - Variable ww_compare : zn2z w -> zn2z w -> comparison. - Variable w_head0 : w -> w. - Variable w_tail0 : w -> w. - Variable w_add: w -> w -> zn2z w. - Variable w_add_mul_div : w -> w -> w -> w. - Variable ww_sub: zn2z w -> zn2z w -> zn2z w. - Variable w_digits : positive. - Variable ww_Digits : positive. - Variable w_zdigits : w. - Variable ww_zdigits : zn2z w. - Variable low: zn2z w -> w. - - Definition ww_head0 x := - match x with - | W0 => ww_zdigits - | WW xh xl => - match w_compare w_0 xh with - | Eq => w_add w_zdigits (w_head0 xl) - | _ => w_0W (w_head0 xh) - end - end. - - - Definition ww_tail0 x := - match x with - | W0 => ww_zdigits - | WW xh xl => - match w_compare w_0 xl with - | Eq => w_add w_zdigits (w_tail0 xh) - | _ => w_0W (w_tail0 xl) - end - end. - - - (* 0 < p < ww_digits *) - Definition ww_add_mul_div p x y := - let zdigits := w_0W w_zdigits in - match x, y with - | W0, W0 => W0 - | W0, WW yh yl => - match ww_compare p zdigits with - | Eq => w_0W yh - | Lt => w_0W (w_add_mul_div (low p) w_0 yh) - | Gt => - let n := low (ww_sub p zdigits) in - w_WW (w_add_mul_div n w_0 yh) (w_add_mul_div n yh yl) - end - | WW xh xl, W0 => - match ww_compare p zdigits with - | Eq => w_W0 xl - | Lt => w_WW (w_add_mul_div (low p) xh xl) (w_add_mul_div (low p) xl w_0) - | Gt => - let n := low (ww_sub p zdigits) in - w_W0 (w_add_mul_div n xl w_0) - end - | WW xh xl, WW yh yl => - match ww_compare p zdigits with - | Eq => w_WW xl yh - | Lt => w_WW (w_add_mul_div (low p) xh xl) (w_add_mul_div (low p) xl yh) - | Gt => - let n := low (ww_sub p zdigits) in - w_WW (w_add_mul_div n xl yh) (w_add_mul_div n yh yl) - end - end. - - Section DoubleProof. - Variable w_to_Z : w -> Z. - - Notation wB := (base w_digits). - Notation wwB := (base (ww_digits w_digits)). - Notation "[| x |]" := (w_to_Z x) (at level 0, x at level 99). - Notation "[[ x ]]" := (ww_to_Z w_digits w_to_Z x)(at level 0, x at level 99). - - Variable spec_w_0 : [|w_0|] = 0. - Variable spec_to_Z : forall x, 0 <= [|x|] < wB. - Variable spec_to_w_Z : forall x, 0 <= [[x]] < wwB. - Variable spec_w_WW : forall h l, [[w_WW h l]] = [|h|] * wB + [|l|]. - Variable spec_w_W0 : forall h, [[w_W0 h]] = [|h|] * wB. - Variable spec_w_0W : forall l, [[w_0W l]] = [|l|]. - Variable spec_compare : forall x y, - w_compare x y = Z.compare [|x|] [|y|]. - Variable spec_ww_compare : forall x y, - ww_compare x y = Z.compare [[x]] [[y]]. - Variable spec_ww_digits : ww_Digits = xO w_digits. - Variable spec_w_head00 : forall x, [|x|] = 0 -> [|w_head0 x|] = Zpos w_digits. - Variable spec_w_head0 : forall x, 0 < [|x|] -> - wB/ 2 <= 2 ^ ([|w_head0 x|]) * [|x|] < wB. - Variable spec_w_tail00 : forall x, [|x|] = 0 -> [|w_tail0 x|] = Zpos w_digits. - Variable spec_w_tail0 : forall x, 0 < [|x|] -> - exists y, 0 <= y /\ [|x|] = (2* y + 1) * (2 ^ [|w_tail0 x|]). - Variable spec_w_add_mul_div : forall x y p, - [|p|] <= Zpos w_digits -> - [| w_add_mul_div p x y |] = - ([|x|] * (2 ^ [|p|]) + - [|y|] / (2 ^ ((Zpos w_digits) - [|p|]))) mod wB. - Variable spec_w_add: forall x y, - [[w_add x y]] = [|x|] + [|y|]. - Variable spec_ww_sub: forall x y, - [[ww_sub x y]] = ([[x]] - [[y]]) mod wwB. - - Variable spec_zdigits : [| w_zdigits |] = Zpos w_digits. - Variable spec_low: forall x, [| low x|] = [[x]] mod wB. - - Variable spec_ww_zdigits : [[ww_zdigits]] = Zpos ww_Digits. - - Hint Resolve div_le_0 div_lt w_to_Z_wwB: lift. - Ltac zarith := auto with zarith lift. - - Lemma spec_ww_head00 : forall x, [[x]] = 0 -> [[ww_head0 x]] = Zpos ww_Digits. - Proof. - intros x; case x; unfold ww_head0. - intros HH; rewrite spec_ww_zdigits; auto. - intros xh xl; simpl; intros Hx. - case (spec_to_Z xh); intros Hx1 Hx2. - case (spec_to_Z xl); intros Hy1 Hy2. - assert (F1: [|xh|] = 0). - { Z.le_elim Hy1; auto. - - absurd (0 < [|xh|] * wB + [|xl|]); auto with zarith. - apply Z.lt_le_trans with (1 := Hy1); auto with zarith. - pattern [|xl|] at 1; rewrite <- (Z.add_0_l [|xl|]). - apply Z.add_le_mono_r; auto with zarith. - - Z.le_elim Hx1; auto. - absurd (0 < [|xh|] * wB + [|xl|]); auto with zarith. - rewrite <- Hy1; rewrite Z.add_0_r; auto with zarith. - apply Z.mul_pos_pos; auto with zarith. } - rewrite spec_compare. case Z.compare_spec. - intros H; simpl. - rewrite spec_w_add; rewrite spec_w_head00. - rewrite spec_zdigits; rewrite spec_ww_digits. - rewrite Pos2Z.inj_xO; auto with zarith. - rewrite F1 in Hx; auto with zarith. - rewrite spec_w_0; auto with zarith. - rewrite spec_w_0; auto with zarith. - Qed. - - Lemma spec_ww_head0 : forall x, 0 < [[x]] -> - wwB/ 2 <= 2 ^ [[ww_head0 x]] * [[x]] < wwB. - Proof. - clear spec_ww_zdigits. - rewrite wwB_div_2;rewrite Z.mul_comm;rewrite wwB_wBwB. - assert (U:= lt_0_wB w_digits); destruct x as [ |xh xl];simpl ww_to_Z;intros H. - unfold Z.lt in H;discriminate H. - rewrite spec_compare, spec_w_0. case Z.compare_spec; intros H0. - rewrite <- H0 in *. simpl Z.add. simpl in H. - case (spec_to_Z w_zdigits); - case (spec_to_Z (w_head0 xl)); intros HH1 HH2 HH3 HH4. - rewrite spec_w_add. - rewrite spec_zdigits; rewrite Zpower_exp; auto with zarith. - case (spec_w_head0 H); intros H1 H2. - rewrite Z.pow_2_r; fold wB; rewrite <- Z.mul_assoc; split. - apply Z.mul_le_mono_nonneg_l; auto with zarith. - apply Z.mul_lt_mono_pos_l; auto with zarith. - assert (H1 := spec_w_head0 H0). - rewrite spec_w_0W. - split. - rewrite Z.mul_add_distr_l;rewrite Z.mul_assoc. - apply Z.le_trans with (2 ^ [|w_head0 xh|] * [|xh|] * wB). - rewrite Z.mul_comm; zarith. - assert (0 <= 2 ^ [|w_head0 xh|] * [|xl|]);zarith. - assert (H2:=spec_to_Z xl);apply Z.mul_nonneg_nonneg;zarith. - case (spec_to_Z (w_head0 xh)); intros H2 _. - generalize ([|w_head0 xh|]) H1 H2;clear H1 H2; - intros p H1 H2. - assert (Eq1 : 2^p < wB). - rewrite <- (Z.mul_1_r (2^p));apply Z.le_lt_trans with (2^p*[|xh|]);zarith. - assert (Eq2: p < Zpos w_digits). - destruct (Z.le_gt_cases (Zpos w_digits) p);trivial;contradict Eq1. - apply Z.le_ngt;unfold base;apply Zpower_le_monotone;zarith. - assert (Zpos w_digits = p + (Zpos w_digits - p)). ring. - rewrite Z.pow_2_r. - unfold base at 2;rewrite H3;rewrite Zpower_exp;zarith. - rewrite <- Z.mul_assoc; apply Z.mul_lt_mono_pos_l; zarith. - rewrite <- (Z.add_0_r (2^(Zpos w_digits - p)*wB));apply beta_lex_inv;zarith. - apply Z.mul_lt_mono_pos_r with (2 ^ p); zarith. - rewrite <- Zpower_exp;zarith. - rewrite Z.mul_comm;ring_simplify (Zpos w_digits - p + p);fold wB;zarith. - assert (H1 := spec_to_Z xh);zarith. - Qed. - - Lemma spec_ww_tail00 : forall x, [[x]] = 0 -> [[ww_tail0 x]] = Zpos ww_Digits. - Proof. - intros x; case x; unfold ww_tail0. - intros HH; rewrite spec_ww_zdigits; auto. - intros xh xl; simpl; intros Hx. - case (spec_to_Z xh); intros Hx1 Hx2. - case (spec_to_Z xl); intros Hy1 Hy2. - assert (F1: [|xh|] = 0). - { Z.le_elim Hy1; auto. - - absurd (0 < [|xh|] * wB + [|xl|]); auto with zarith. - apply Z.lt_le_trans with (1 := Hy1); auto with zarith. - pattern [|xl|] at 1; rewrite <- (Z.add_0_l [|xl|]). - apply Z.add_le_mono_r; auto with zarith. - - Z.le_elim Hx1; auto. - absurd (0 < [|xh|] * wB + [|xl|]); auto with zarith. - rewrite <- Hy1; rewrite Z.add_0_r; auto with zarith. - apply Z.mul_pos_pos; auto with zarith. } - assert (F2: [|xl|] = 0). - rewrite F1 in Hx; auto with zarith. - rewrite spec_compare; case Z.compare_spec. - intros H; simpl. - rewrite spec_w_add; rewrite spec_w_tail00; auto. - rewrite spec_zdigits; rewrite spec_ww_digits. - rewrite Pos2Z.inj_xO; auto with zarith. - rewrite spec_w_0; auto with zarith. - rewrite spec_w_0; auto with zarith. - Qed. - - Lemma spec_ww_tail0 : forall x, 0 < [[x]] -> - exists y, 0 <= y /\ [[x]] = (2 * y + 1) * 2 ^ [[ww_tail0 x]]. - Proof. - clear spec_ww_zdigits. - destruct x as [ |xh xl];simpl ww_to_Z;intros H. - unfold Z.lt in H;discriminate H. - rewrite spec_compare, spec_w_0. case Z.compare_spec; intros H0. - rewrite <- H0; rewrite Z.add_0_r. - case (spec_to_Z (w_tail0 xh)); intros HH1 HH2. - generalize H; rewrite <- H0; rewrite Z.add_0_r; clear H; intros H. - case (@spec_w_tail0 xh). - apply Z.mul_lt_mono_pos_r with wB; auto with zarith. - unfold base; auto with zarith. - intros z (Hz1, Hz2); exists z; split; auto. - rewrite spec_w_add; rewrite (fun x => Z.add_comm [|x|]). - rewrite spec_zdigits; rewrite Zpower_exp; auto with zarith. - rewrite Z.mul_assoc; rewrite <- Hz2; auto. - - case (spec_to_Z (w_tail0 xh)); intros HH1 HH2. - case (spec_w_tail0 H0); intros z (Hz1, Hz2). - assert (Hp: [|w_tail0 xl|] < Zpos w_digits). - case (Z.le_gt_cases (Zpos w_digits) [|w_tail0 xl|]); auto; intros H1. - absurd (2 ^ (Zpos w_digits) <= 2 ^ [|w_tail0 xl|]). - apply Z.lt_nge. - case (spec_to_Z xl); intros HH3 HH4. - apply Z.le_lt_trans with (2 := HH4). - apply Z.le_trans with (1 * 2 ^ [|w_tail0 xl|]); auto with zarith. - rewrite Hz2. - apply Z.mul_le_mono_nonneg_r; auto with zarith. - apply Zpower_le_monotone; auto with zarith. - exists ([|xh|] * (2 ^ ((Zpos w_digits - [|w_tail0 xl|]) - 1)) + z); split. - apply Z.add_nonneg_nonneg; auto. - apply Z.mul_nonneg_nonneg; auto with zarith. - case (spec_to_Z xh); auto. - rewrite spec_w_0W. - rewrite (Z.mul_add_distr_l 2); rewrite <- Z.add_assoc. - rewrite Z.mul_add_distr_r; rewrite <- Hz2. - apply f_equal2 with (f := Z.add); auto. - rewrite (Z.mul_comm 2). - repeat rewrite <- Z.mul_assoc. - apply f_equal2 with (f := Z.mul); auto. - case (spec_to_Z (w_tail0 xl)); intros HH3 HH4. - pattern 2 at 2; rewrite <- Z.pow_1_r. - lazy beta; repeat rewrite <- Zpower_exp; auto with zarith. - unfold base; apply f_equal with (f := Z.pow 2); auto with zarith. - - contradict H0; case (spec_to_Z xl); auto with zarith. - Qed. - - Hint Rewrite Zdiv_0_l Z.mul_0_l Z.add_0_l Z.mul_0_r Z.add_0_r - spec_w_W0 spec_w_0W spec_w_WW spec_w_0 - (wB_div w_digits w_to_Z spec_to_Z) - (wB_div_plus w_digits w_to_Z spec_to_Z) : w_rewrite. - Ltac w_rewrite := autorewrite with w_rewrite;trivial. - - Lemma spec_ww_add_mul_div_aux : forall xh xl yh yl p, - let zdigits := w_0W w_zdigits in - [[p]] <= Zpos (xO w_digits) -> - [[match ww_compare p zdigits with - | Eq => w_WW xl yh - | Lt => w_WW (w_add_mul_div (low p) xh xl) - (w_add_mul_div (low p) xl yh) - | Gt => - let n := low (ww_sub p zdigits) in - w_WW (w_add_mul_div n xl yh) (w_add_mul_div n yh yl) - end]] = - ([[WW xh xl]] * (2^[[p]]) + - [[WW yh yl]] / (2^(Zpos (xO w_digits) - [[p]]))) mod wwB. - Proof. - clear spec_ww_zdigits. - intros xh xl yh yl p zdigits;assert (HwwB := wwB_pos w_digits). - case (spec_to_w_Z p); intros Hv1 Hv2. - replace (Zpos (xO w_digits)) with (Zpos w_digits + Zpos w_digits). - 2 : rewrite Pos2Z.inj_xO;ring. - replace (Zpos w_digits + Zpos w_digits - [[p]]) with - (Zpos w_digits + (Zpos w_digits - [[p]])). 2:ring. - intros Hp; assert (Hxh := spec_to_Z xh);assert (Hxl:=spec_to_Z xl); - assert (Hx := spec_ww_to_Z w_digits w_to_Z spec_to_Z (WW xh xl)); - simpl in Hx;assert (Hyh := spec_to_Z yh);assert (Hyl:=spec_to_Z yl); - assert (Hy:=spec_ww_to_Z w_digits w_to_Z spec_to_Z (WW yh yl));simpl in Hy. - rewrite spec_ww_compare; case Z.compare_spec; intros H1. - rewrite H1; unfold zdigits; rewrite spec_w_0W. - rewrite spec_zdigits; rewrite Z.sub_diag; rewrite Z.add_0_r. - simpl ww_to_Z; w_rewrite;zarith. - fold wB. - rewrite Z.mul_add_distr_r;rewrite <- Z.mul_assoc;rewrite <- Z.add_assoc. - rewrite <- Z.pow_2_r. - rewrite <- wwB_wBwB;apply Zmod_unique with [|xh|]. - exact (spec_ww_to_Z w_digits w_to_Z spec_to_Z (WW xl yh)). ring. - simpl ww_to_Z; w_rewrite;zarith. - assert (HH0: [|low p|] = [[p]]). - rewrite spec_low. - apply Zmod_small. - case (spec_to_w_Z p); intros HH1 HH2; split; auto. - generalize H1; unfold zdigits; rewrite spec_w_0W; - rewrite spec_zdigits; intros tmp. - apply Z.lt_le_trans with (1 := tmp). - unfold base. - apply Zpower2_le_lin; auto with zarith. - 2: generalize H1; unfold zdigits; rewrite spec_w_0W; - rewrite spec_zdigits; auto with zarith. - generalize H1; unfold zdigits; rewrite spec_w_0W; - rewrite spec_zdigits; auto; clear H1; intros H1. - assert (HH: [|low p|] <= Zpos w_digits). - rewrite HH0; auto with zarith. - repeat rewrite spec_w_add_mul_div with (1 := HH). - rewrite HH0. - rewrite Z.mul_add_distr_r. - pattern ([|xl|] * 2 ^ [[p]]) at 2; - rewrite shift_unshift_mod with (n:= Zpos w_digits);fold wB;zarith. - replace ([|xh|] * wB * 2^[[p]]) with ([|xh|] * 2^[[p]] * wB). 2:ring. - rewrite Z.add_assoc;rewrite <- Z.mul_add_distr_r. rewrite <- Z.add_assoc. - unfold base at 5;rewrite <- Zmod_shift_r;zarith. - unfold base;rewrite Zmod_shift_r with (b:= Zpos (ww_digits w_digits)); - fold wB;fold wwB;zarith. - rewrite wwB_wBwB;rewrite Z.pow_2_r; rewrite Zmult_mod_distr_r;zarith. - unfold ww_digits;rewrite Pos2Z.inj_xO;zarith. apply Z_mod_lt;zarith. - split;zarith. apply Zdiv_lt_upper_bound;zarith. - rewrite <- Zpower_exp;zarith. - ring_simplify ([[p]] + (Zpos w_digits - [[p]]));fold wB;zarith. - assert (Hv: [[p]] > Zpos w_digits). - generalize H1; clear H1. - unfold zdigits; rewrite spec_w_0W; rewrite spec_zdigits; auto with zarith. - clear H1. - assert (HH0: [|low (ww_sub p zdigits)|] = [[p]] - Zpos w_digits). - rewrite spec_low. - rewrite spec_ww_sub. - unfold zdigits; rewrite spec_w_0W; rewrite spec_zdigits. - rewrite <- Zmod_div_mod; auto with zarith. - rewrite Zmod_small; auto with zarith. - split; auto with zarith. - apply Z.le_lt_trans with (Zpos w_digits); auto with zarith. - unfold base; apply Zpower2_lt_lin; auto with zarith. - exists wB; unfold base. - unfold ww_digits; rewrite (Pos2Z.inj_xO w_digits). - rewrite <- Zpower_exp; auto with zarith. - apply f_equal with (f := fun x => 2 ^ x); auto with zarith. - assert (HH: [|low (ww_sub p zdigits)|] <= Zpos w_digits). - rewrite HH0; auto with zarith. - replace (Zpos w_digits + (Zpos w_digits - [[p]])) with - (Zpos w_digits - ([[p]] - Zpos w_digits)); zarith. - lazy zeta; simpl ww_to_Z; w_rewrite;zarith. - repeat rewrite spec_w_add_mul_div;zarith. - rewrite HH0. - pattern wB at 5;replace wB with - (2^(([[p]] - Zpos w_digits) - + (Zpos w_digits - ([[p]] - Zpos w_digits)))). - rewrite Zpower_exp;zarith. rewrite Z.mul_assoc. - rewrite Z_div_plus_l;zarith. - rewrite shift_unshift_mod with (a:= [|yh|]) (p:= [[p]] - Zpos w_digits) - (n := Zpos w_digits);zarith. fold wB. - set (u := [[p]] - Zpos w_digits). - replace [[p]] with (u + Zpos w_digits);zarith. - rewrite Zpower_exp;zarith. rewrite Z.mul_assoc. fold wB. - repeat rewrite Z.add_assoc. rewrite <- Z.mul_add_distr_r. - repeat rewrite <- Z.add_assoc. - unfold base;rewrite Zmod_shift_r with (b:= Zpos (ww_digits w_digits)); - fold wB;fold wwB;zarith. - unfold base;rewrite Zmod_shift_r with (a:= Zpos w_digits) - (b:= Zpos w_digits);fold wB;fold wwB;zarith. - rewrite wwB_wBwB; rewrite Z.pow_2_r; rewrite Zmult_mod_distr_r;zarith. - rewrite Z.mul_add_distr_r. - replace ([|xh|] * wB * 2 ^ u) with - ([|xh|]*2^u*wB). 2:ring. - repeat rewrite <- Z.add_assoc. - rewrite (Z.add_comm ([|xh|] * 2 ^ u * wB)). - rewrite Z_mod_plus;zarith. rewrite Z_mod_mult;zarith. - unfold base;rewrite <- Zmod_shift_r;zarith. fold base;apply Z_mod_lt;zarith. - unfold u; split;zarith. - split;zarith. unfold u; apply Zdiv_lt_upper_bound;zarith. - rewrite <- Zpower_exp;zarith. - fold u. - ring_simplify (u + (Zpos w_digits - u)); fold - wB;zarith. unfold ww_digits;rewrite Pos2Z.inj_xO;zarith. - unfold base;rewrite <- Zmod_shift_r;zarith. fold base;apply Z_mod_lt;zarith. - unfold u; split;zarith. - unfold u; split;zarith. - apply Zdiv_lt_upper_bound;zarith. - rewrite <- Zpower_exp;zarith. - fold u. - ring_simplify (u + (Zpos w_digits - u)); fold wB; auto with zarith. - unfold u;zarith. - unfold u;zarith. - set (u := [[p]] - Zpos w_digits). - ring_simplify (u + (Zpos w_digits - u)); fold wB; auto with zarith. - Qed. - - Lemma spec_ww_add_mul_div : forall x y p, - [[p]] <= Zpos (xO w_digits) -> - [[ ww_add_mul_div p x y ]] = - ([[x]] * (2^[[p]]) + - [[y]] / (2^(Zpos (xO w_digits) - [[p]]))) mod wwB. - Proof. - clear spec_ww_zdigits. - intros x y p H. - destruct x as [ |xh xl]; - [assert (H1 := @spec_ww_add_mul_div_aux w_0 w_0) - |assert (H1 := @spec_ww_add_mul_div_aux xh xl)]; - (destruct y as [ |yh yl]; - [generalize (H1 w_0 w_0 p H) | generalize (H1 yh yl p H)]; - clear H1;w_rewrite);simpl ww_add_mul_div. - replace [[WW w_0 w_0]] with 0;[w_rewrite|simpl;w_rewrite;trivial]. - intros Heq;rewrite <- Heq;clear Heq; auto. - rewrite spec_ww_compare. case Z.compare_spec; intros H1; w_rewrite. - rewrite (spec_w_add_mul_div w_0 w_0);w_rewrite;zarith. - generalize H1; w_rewrite; rewrite spec_zdigits; clear H1; intros H1. - assert (HH0: [|low p|] = [[p]]). - rewrite spec_low. - apply Zmod_small. - case (spec_to_w_Z p); intros HH1 HH2; split; auto. - apply Z.lt_le_trans with (1 := H1). - unfold base; apply Zpower2_le_lin; auto with zarith. - rewrite HH0; auto with zarith. - replace [[WW w_0 w_0]] with 0;[w_rewrite|simpl;w_rewrite;trivial]. - intros Heq;rewrite <- Heq;clear Heq. - generalize (spec_ww_compare p (w_0W w_zdigits)); - case ww_compare; intros H1; w_rewrite. - rewrite (spec_w_add_mul_div w_0 w_0);w_rewrite;zarith. - rewrite Pos2Z.inj_xO in H;zarith. - assert (HH: [|low (ww_sub p (w_0W w_zdigits)) |] = [[p]] - Zpos w_digits). - symmetry in H1; change ([[p]] > [[w_0W w_zdigits]]) in H1. - revert H1. - rewrite spec_low. - rewrite spec_ww_sub; w_rewrite; intros H1. - rewrite <- Zmod_div_mod; auto with zarith. - rewrite Zmod_small; auto with zarith. - split; auto with zarith. - apply Z.le_lt_trans with (Zpos w_digits); auto with zarith. - unfold base; apply Zpower2_lt_lin; auto with zarith. - unfold base; auto with zarith. - unfold base; auto with zarith. - exists wB; unfold base. - unfold ww_digits; rewrite (Pos2Z.inj_xO w_digits). - rewrite <- Zpower_exp; auto with zarith. - apply f_equal with (f := fun x => 2 ^ x); auto with zarith. - case (spec_to_Z xh); auto with zarith. - Qed. - - End DoubleProof. - -End DoubleLift. - diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleMul.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleMul.v deleted file mode 100644 index b990139004..0000000000 --- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleMul.v +++ /dev/null @@ -1,621 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) -(* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) -(************************************************************************) - -Set Implicit Arguments. - -Require Import ZArith. -Require Import BigNumPrelude. -Require Import DoubleType. -Require Import DoubleBase. - -Local Open Scope Z_scope. - -Section DoubleMul. - Variable w : Type. - Variable w_0 : w. - Variable w_1 : w. - Variable w_WW : w -> w -> zn2z w. - Variable w_W0 : w -> zn2z w. - Variable w_0W : w -> zn2z w. - Variable w_compare : w -> w -> comparison. - Variable w_succ : w -> w. - Variable w_add_c : w -> w -> carry w. - Variable w_add : w -> w -> w. - Variable w_sub: w -> w -> w. - Variable w_mul_c : w -> w -> zn2z w. - Variable w_mul : w -> w -> w. - Variable w_square_c : w -> zn2z w. - Variable ww_add_c : zn2z w -> zn2z w -> carry (zn2z w). - Variable ww_add : zn2z w -> zn2z w -> zn2z w. - Variable ww_add_carry : zn2z w -> zn2z w -> zn2z w. - Variable ww_sub_c : zn2z w -> zn2z w -> carry (zn2z w). - Variable ww_sub : zn2z w -> zn2z w -> zn2z w. - - (* ** Multiplication ** *) - - (* (xh*B+xl) (yh*B + yl) - xh*yh = hh = |hhh|hhl|B2 - xh*yl +xl*yh = cc = |cch|ccl|B - xl*yl = ll = |llh|lll - *) - - Definition double_mul_c (cross:w->w->w->w->zn2z w -> zn2z w -> w*zn2z w) x y := - match x, y with - | W0, _ => W0 - | _, W0 => W0 - | WW xh xl, WW yh yl => - let hh := w_mul_c xh yh in - let ll := w_mul_c xl yl in - let (wc,cc) := cross xh xl yh yl hh ll in - match cc with - | W0 => WW (ww_add hh (w_W0 wc)) ll - | WW cch ccl => - match ww_add_c (w_W0 ccl) ll with - | C0 l => WW (ww_add hh (w_WW wc cch)) l - | C1 l => WW (ww_add_carry hh (w_WW wc cch)) l - end - end - end. - - Definition ww_mul_c := - double_mul_c - (fun xh xl yh yl hh ll=> - match ww_add_c (w_mul_c xh yl) (w_mul_c xl yh) with - | C0 cc => (w_0, cc) - | C1 cc => (w_1, cc) - end). - - Definition w_2 := w_add w_1 w_1. - - Definition kara_prod xh xl yh yl hh ll := - match ww_add_c hh ll with - C0 m => - match w_compare xl xh with - Eq => (w_0, m) - | Lt => - match w_compare yl yh with - Eq => (w_0, m) - | Lt => (w_0, ww_sub m (w_mul_c (w_sub xh xl) (w_sub yh yl))) - | Gt => match ww_add_c m (w_mul_c (w_sub xh xl) (w_sub yl yh)) with - C1 m1 => (w_1, m1) | C0 m1 => (w_0, m1) - end - end - | Gt => - match w_compare yl yh with - Eq => (w_0, m) - | Lt => match ww_add_c m (w_mul_c (w_sub xl xh) (w_sub yh yl)) with - C1 m1 => (w_1, m1) | C0 m1 => (w_0, m1) - end - | Gt => (w_0, ww_sub m (w_mul_c (w_sub xl xh) (w_sub yl yh))) - end - end - | C1 m => - match w_compare xl xh with - Eq => (w_1, m) - | Lt => - match w_compare yl yh with - Eq => (w_1, m) - | Lt => match ww_sub_c m (w_mul_c (w_sub xh xl) (w_sub yh yl)) with - C0 m1 => (w_1, m1) | C1 m1 => (w_0, m1) - end - | Gt => match ww_add_c m (w_mul_c (w_sub xh xl) (w_sub yl yh)) with - C1 m1 => (w_2, m1) | C0 m1 => (w_1, m1) - end - end - | Gt => - match w_compare yl yh with - Eq => (w_1, m) - | Lt => match ww_add_c m (w_mul_c (w_sub xl xh) (w_sub yh yl)) with - C1 m1 => (w_2, m1) | C0 m1 => (w_1, m1) - end - | Gt => match ww_sub_c m (w_mul_c (w_sub xl xh) (w_sub yl yh)) with - C1 m1 => (w_0, m1) | C0 m1 => (w_1, m1) - end - end - end - end. - - Definition ww_karatsuba_c := double_mul_c kara_prod. - - Definition ww_mul x y := - match x, y with - | W0, _ => W0 - | _, W0 => W0 - | WW xh xl, WW yh yl => - let ccl := w_add (w_mul xh yl) (w_mul xl yh) in - ww_add (w_W0 ccl) (w_mul_c xl yl) - end. - - Definition ww_square_c x := - match x with - | W0 => W0 - | WW xh xl => - let hh := w_square_c xh in - let ll := w_square_c xl in - let xhxl := w_mul_c xh xl in - let (wc,cc) := - match ww_add_c xhxl xhxl with - | C0 cc => (w_0, cc) - | C1 cc => (w_1, cc) - end in - match cc with - | W0 => WW (ww_add hh (w_W0 wc)) ll - | WW cch ccl => - match ww_add_c (w_W0 ccl) ll with - | C0 l => WW (ww_add hh (w_WW wc cch)) l - | C1 l => WW (ww_add_carry hh (w_WW wc cch)) l - end - end - end. - - Section DoubleMulAddn1. - Variable w_mul_add : w -> w -> w -> w * w. - - Fixpoint double_mul_add_n1 (n:nat) : word w n -> w -> w -> w * word w n := - match n return word w n -> w -> w -> w * word w n with - | O => w_mul_add - | S n1 => - let mul_add := double_mul_add_n1 n1 in - fun x y r => - match x with - | W0 => (w_0,extend w_0W n1 r) - | WW xh xl => - let (rl,l) := mul_add xl y r in - let (rh,h) := mul_add xh y rl in - (rh, double_WW w_WW n1 h l) - end - end. - - End DoubleMulAddn1. - - Section DoubleMulAddmn1. - Variable wn: Type. - Variable extend_n : w -> wn. - Variable wn_0W : wn -> zn2z wn. - Variable wn_WW : wn -> wn -> zn2z wn. - Variable w_mul_add_n1 : wn -> w -> w -> w*wn. - Fixpoint double_mul_add_mn1 (m:nat) : - word wn m -> w -> w -> w*word wn m := - match m return word wn m -> w -> w -> w*word wn m with - | O => w_mul_add_n1 - | S m1 => - let mul_add := double_mul_add_mn1 m1 in - fun x y r => - match x with - | W0 => (w_0,extend wn_0W m1 (extend_n r)) - | WW xh xl => - let (rl,l) := mul_add xl y r in - let (rh,h) := mul_add xh y rl in - (rh, double_WW wn_WW m1 h l) - end - end. - - End DoubleMulAddmn1. - - Definition w_mul_add x y r := - match w_mul_c x y with - | W0 => (w_0, r) - | WW h l => - match w_add_c l r with - | C0 lr => (h,lr) - | C1 lr => (w_succ h, lr) - end - end. - - - (*Section DoubleProof. *) - Variable w_digits : positive. - Variable w_to_Z : w -> Z. - - Notation wB := (base w_digits). - Notation wwB := (base (ww_digits w_digits)). - Notation "[| x |]" := (w_to_Z x) (at level 0, x at level 99). - Notation "[+| c |]" := - (interp_carry 1 wB w_to_Z c) (at level 0, c at level 99). - Notation "[-| c |]" := - (interp_carry (-1) wB w_to_Z c) (at level 0, c at level 99). - - Notation "[[ x ]]" := (ww_to_Z w_digits w_to_Z x)(at level 0, x at level 99). - Notation "[+[ c ]]" := - (interp_carry 1 wwB (ww_to_Z w_digits w_to_Z) c) - (at level 0, c at level 99). - Notation "[-[ c ]]" := - (interp_carry (-1) wwB (ww_to_Z w_digits w_to_Z) c) - (at level 0, c at level 99). - - Notation "[|| x ||]" := - (zn2z_to_Z wwB (ww_to_Z w_digits w_to_Z) x) (at level 0, x at level 99). - - Notation "[! n | x !]" := (double_to_Z w_digits w_to_Z n x) - (at level 0, x at level 99). - - Variable spec_more_than_1_digit: 1 < Zpos w_digits. - Variable spec_w_0 : [|w_0|] = 0. - Variable spec_w_1 : [|w_1|] = 1. - - Variable spec_to_Z : forall x, 0 <= [|x|] < wB. - - Variable spec_w_WW : forall h l, [[w_WW h l]] = [|h|] * wB + [|l|]. - Variable spec_w_W0 : forall h, [[w_W0 h]] = [|h|] * wB. - Variable spec_w_0W : forall l, [[w_0W l]] = [|l|]. - Variable spec_w_compare : - forall x y, w_compare x y = Z.compare [|x|] [|y|]. - Variable spec_w_succ : forall x, [|w_succ x|] = ([|x|] + 1) mod wB. - Variable spec_w_add_c : forall x y, [+|w_add_c x y|] = [|x|] + [|y|]. - Variable spec_w_add : forall x y, [|w_add x y|] = ([|x|] + [|y|]) mod wB. - Variable spec_w_sub : forall x y, [|w_sub x y|] = ([|x|] - [|y|]) mod wB. - - Variable spec_w_mul_c : forall x y, [[ w_mul_c x y ]] = [|x|] * [|y|]. - Variable spec_w_mul : forall x y, [|w_mul x y|] = ([|x|] * [|y|]) mod wB. - Variable spec_w_square_c : forall x, [[ w_square_c x]] = [|x|] * [|x|]. - - Variable spec_ww_add_c : forall x y, [+[ww_add_c x y]] = [[x]] + [[y]]. - Variable spec_ww_add : forall x y, [[ww_add x y]] = ([[x]] + [[y]]) mod wwB. - Variable spec_ww_add_carry : - forall x y, [[ww_add_carry x y]] = ([[x]] + [[y]] + 1) mod wwB. - Variable spec_ww_sub : forall x y, [[ww_sub x y]] = ([[x]] - [[y]]) mod wwB. - Variable spec_ww_sub_c : forall x y, [-[ww_sub_c x y]] = [[x]] - [[y]]. - - - Lemma spec_ww_to_Z : forall x, 0 <= [[x]] < wwB. - Proof. intros x;apply spec_ww_to_Z;auto. Qed. - - Lemma spec_ww_to_Z_wBwB : forall x, 0 <= [[x]] < wB^2. - Proof. rewrite <- wwB_wBwB;apply spec_ww_to_Z. Qed. - - Hint Resolve spec_ww_to_Z spec_ww_to_Z_wBwB : mult. - Ltac zarith := auto with zarith mult. - - Lemma wBwB_lex: forall a b c d, - a * wB^2 + [[b]] <= c * wB^2 + [[d]] -> - a <= c. - Proof. - intros a b c d H; apply beta_lex with [[b]] [[d]] (wB^2);zarith. - Qed. - - Lemma wBwB_lex_inv: forall a b c d, - a < c -> - a * wB^2 + [[b]] < c * wB^2 + [[d]]. - Proof. - intros a b c d H; apply beta_lex_inv; zarith. - Qed. - - Lemma sum_mul_carry : forall xh xl yh yl wc cc, - [|wc|]*wB^2 + [[cc]] = [|xh|] * [|yl|] + [|xl|] * [|yh|] -> - 0 <= [|wc|] <= 1. - Proof. - intros. - apply (sum_mul_carry [|xh|] [|xl|] [|yh|] [|yl|] [|wc|][[cc]] wB);zarith. - apply wB_pos. - Qed. - - Theorem mult_add_ineq: forall xH yH crossH, - 0 <= [|xH|] * [|yH|] + [|crossH|] < wwB. - Proof. - intros;rewrite wwB_wBwB;apply mult_add_ineq;zarith. - Qed. - - Hint Resolve mult_add_ineq : mult. - - Lemma spec_mul_aux : forall xh xl yh yl wc (cc:zn2z w) hh ll, - [[hh]] = [|xh|] * [|yh|] -> - [[ll]] = [|xl|] * [|yl|] -> - [|wc|]*wB^2 + [[cc]] = [|xh|] * [|yl|] + [|xl|] * [|yh|] -> - [||match cc with - | W0 => WW (ww_add hh (w_W0 wc)) ll - | WW cch ccl => - match ww_add_c (w_W0 ccl) ll with - | C0 l => WW (ww_add hh (w_WW wc cch)) l - | C1 l => WW (ww_add_carry hh (w_WW wc cch)) l - end - end||] = ([|xh|] * wB + [|xl|]) * ([|yh|] * wB + [|yl|]). - Proof. - intros;assert (U1 := wB_pos w_digits). - replace (([|xh|] * wB + [|xl|]) * ([|yh|] * wB + [|yl|])) with - ([|xh|]*[|yh|]*wB^2 + ([|xh|]*[|yl|] + [|xl|]*[|yh|])*wB + [|xl|]*[|yl|]). - 2:ring. rewrite <- H1;rewrite <- H;rewrite <- H0. - assert (H2 := sum_mul_carry _ _ _ _ _ _ H1). - destruct cc as [ | cch ccl]; simpl zn2z_to_Z; simpl ww_to_Z. - rewrite spec_ww_add;rewrite spec_w_W0;rewrite Zmod_small; - rewrite wwB_wBwB. ring. - rewrite <- (Z.add_0_r ([|wc|]*wB));rewrite H;apply mult_add_ineq3;zarith. - simpl ww_to_Z in H1. assert (U:=spec_to_Z cch). - assert ([|wc|]*wB + [|cch|] <= 2*wB - 3). - destruct (Z_le_gt_dec ([|wc|]*wB + [|cch|]) (2*wB - 3)) as [Hle|Hgt];trivial. - assert ([|xh|] * [|yl|] + [|xl|] * [|yh|] <= (2*wB - 4)*wB + 2). - ring_simplify ((2*wB - 4)*wB + 2). - assert (H4 := Zmult_lt_b _ _ _ (spec_to_Z xh) (spec_to_Z yl)). - assert (H5 := Zmult_lt_b _ _ _ (spec_to_Z xl) (spec_to_Z yh)). - omega. - generalize H3;clear H3;rewrite <- H1. - rewrite Z.add_assoc; rewrite Z.pow_2_r; rewrite Z.mul_assoc; - rewrite <- Z.mul_add_distr_r. - assert (((2 * wB - 4) + 2)*wB <= ([|wc|] * wB + [|cch|])*wB). - apply Z.mul_le_mono_nonneg;zarith. - rewrite Z.mul_add_distr_r in H3. - intros. assert (U2 := spec_to_Z ccl);omega. - generalize (spec_ww_add_c (w_W0 ccl) ll);destruct (ww_add_c (w_W0 ccl) ll) - as [l|l];unfold interp_carry;rewrite spec_w_W0;try rewrite Z.mul_1_l; - simpl zn2z_to_Z; - try rewrite spec_ww_add;try rewrite spec_ww_add_carry;rewrite spec_w_WW; - rewrite Zmod_small;rewrite wwB_wBwB;intros. - rewrite H4;ring. rewrite H;apply mult_add_ineq2;zarith. - rewrite Z.add_assoc;rewrite Z.mul_add_distr_r. - rewrite Z.mul_1_l;rewrite <- Z.add_assoc;rewrite H4;ring. - repeat rewrite <- Z.add_assoc;rewrite H;apply mult_add_ineq2;zarith. - Qed. - - Lemma spec_double_mul_c : forall cross:w->w->w->w->zn2z w -> zn2z w -> w*zn2z w, - (forall xh xl yh yl hh ll, - [[hh]] = [|xh|]*[|yh|] -> - [[ll]] = [|xl|]*[|yl|] -> - let (wc,cc) := cross xh xl yh yl hh ll in - [|wc|]*wwB + [[cc]] = [|xh|]*[|yl|] + [|xl|]*[|yh|]) -> - forall x y, [||double_mul_c cross x y||] = [[x]] * [[y]]. - Proof. - intros cross Hcross x y;destruct x as [ |xh xl];simpl;trivial. - destruct y as [ |yh yl];simpl. rewrite Z.mul_0_r;trivial. - assert (H1:= spec_w_mul_c xh yh);assert (H2:= spec_w_mul_c xl yl). - generalize (Hcross _ _ _ _ _ _ H1 H2). - destruct (cross xh xl yh yl (w_mul_c xh yh) (w_mul_c xl yl)) as (wc,cc). - intros;apply spec_mul_aux;trivial. - rewrite <- wwB_wBwB;trivial. - Qed. - - Lemma spec_ww_mul_c : forall x y, [||ww_mul_c x y||] = [[x]] * [[y]]. - Proof. - intros x y;unfold ww_mul_c;apply spec_double_mul_c. - intros xh xl yh yl hh ll H1 H2. - generalize (spec_ww_add_c (w_mul_c xh yl) (w_mul_c xl yh)); - destruct (ww_add_c (w_mul_c xh yl) (w_mul_c xl yh)) as [c|c]; - unfold interp_carry;repeat rewrite spec_w_mul_c;intros H; - (rewrite spec_w_0 || rewrite spec_w_1);rewrite H;ring. - Qed. - - Lemma spec_w_2: [|w_2|] = 2. - unfold w_2; rewrite spec_w_add; rewrite spec_w_1; simpl. - apply Zmod_small; split; auto with zarith. - rewrite <- (Z.pow_1_r 2); unfold base; apply Zpower_lt_monotone; auto with zarith. - Qed. - - Lemma kara_prod_aux : forall xh xl yh yl, - xh*yh + xl*yl - (xh-xl)*(yh-yl) = xh*yl + xl*yh. - Proof. intros;ring. Qed. - - Lemma spec_kara_prod : forall xh xl yh yl hh ll, - [[hh]] = [|xh|]*[|yh|] -> - [[ll]] = [|xl|]*[|yl|] -> - let (wc,cc) := kara_prod xh xl yh yl hh ll in - [|wc|]*wwB + [[cc]] = [|xh|]*[|yl|] + [|xl|]*[|yh|]. - Proof. - intros xh xl yh yl hh ll H H0; rewrite <- kara_prod_aux; - rewrite <- H; rewrite <- H0; unfold kara_prod. - assert (Hxh := (spec_to_Z xh)); assert (Hxl := (spec_to_Z xl)); - assert (Hyh := (spec_to_Z yh)); assert (Hyl := (spec_to_Z yl)). - generalize (spec_ww_add_c hh ll); case (ww_add_c hh ll); - intros z Hz; rewrite <- Hz; unfold interp_carry; assert (Hz1 := (spec_ww_to_Z z)). - rewrite spec_w_compare; case Z.compare_spec; intros Hxlh; - try rewrite Hxlh; try rewrite spec_w_0; try (ring; fail). - rewrite spec_w_compare; case Z.compare_spec; intros Hylh. - rewrite Hylh; rewrite spec_w_0; try (ring; fail). - rewrite spec_w_0; try (ring; fail). - repeat (rewrite spec_ww_sub || rewrite spec_w_sub || rewrite spec_w_mul_c). - repeat rewrite Zmod_small; auto with zarith; try (ring; fail). - split; auto with zarith. - simpl in Hz; rewrite Hz; rewrite H; rewrite H0. - rewrite kara_prod_aux; apply Z.add_nonneg_nonneg; apply Z.mul_nonneg_nonneg; auto with zarith. - apply Z.le_lt_trans with ([[z]]-0); auto with zarith. - unfold Z.sub; apply Z.add_le_mono_l; apply Z.le_0_sub; simpl; rewrite Z.opp_involutive. - apply Z.mul_nonneg_nonneg; auto with zarith. - match goal with |- context[ww_add_c ?x ?y] => - generalize (spec_ww_add_c x y); case (ww_add_c x y); try rewrite spec_w_0; - intros z1 Hz2 - end. - simpl in Hz2; rewrite Hz2; repeat (rewrite spec_w_sub || rewrite spec_w_mul_c). - repeat rewrite Zmod_small; auto with zarith; try (ring; fail). - rewrite spec_w_1; unfold interp_carry in Hz2; rewrite Hz2; - repeat (rewrite spec_w_sub || rewrite spec_w_mul_c). - repeat rewrite Zmod_small; auto with zarith; try (ring; fail). - rewrite spec_w_compare; case Z.compare_spec; intros Hylh. - rewrite Hylh; rewrite spec_w_0; try (ring; fail). - match goal with |- context[ww_add_c ?x ?y] => - generalize (spec_ww_add_c x y); case (ww_add_c x y); try rewrite spec_w_0; - intros z1 Hz2 - end. - simpl in Hz2; rewrite Hz2; repeat (rewrite spec_w_sub || rewrite spec_w_mul_c). - repeat rewrite Zmod_small; auto with zarith; try (ring; fail). - rewrite spec_w_1; unfold interp_carry in Hz2; rewrite Hz2; - repeat (rewrite spec_w_sub || rewrite spec_w_mul_c). - repeat rewrite Zmod_small; auto with zarith; try (ring; fail). - rewrite spec_w_0; try (ring; fail). - repeat (rewrite spec_ww_sub || rewrite spec_w_sub || rewrite spec_w_mul_c). - repeat rewrite Zmod_small; auto with zarith; try (ring; fail). - split. - match goal with |- context[(?x - ?y) * (?z - ?t)] => - replace ((x - y) * (z - t)) with ((y - x) * (t - z)); [idtac | ring] - end. - simpl in Hz; rewrite Hz; rewrite H; rewrite H0. - rewrite kara_prod_aux; apply Z.add_nonneg_nonneg; apply Z.mul_nonneg_nonneg; auto with zarith. - apply Z.le_lt_trans with ([[z]]-0); auto with zarith. - unfold Z.sub; apply Z.add_le_mono_l; apply Z.le_0_sub; simpl; rewrite Z.opp_involutive. - apply Z.mul_nonneg_nonneg; auto with zarith. - (** there is a carry in hh + ll **) - rewrite Z.mul_1_l. - rewrite spec_w_compare; case Z.compare_spec; intros Hxlh; - try rewrite Hxlh; try rewrite spec_w_1; try (ring; fail). - rewrite spec_w_compare; case Z.compare_spec; intros Hylh; - try rewrite Hylh; try rewrite spec_w_1; try (ring; fail). - match goal with |- context[ww_sub_c ?x ?y] => - generalize (spec_ww_sub_c x y); case (ww_sub_c x y); try rewrite spec_w_1; - intros z1 Hz2 - end. - simpl in Hz2; rewrite Hz2; repeat (rewrite spec_w_sub || rewrite spec_w_mul_c). - repeat rewrite Zmod_small; auto with zarith; try (ring; fail). - rewrite spec_w_0; rewrite Z.mul_0_l; rewrite Z.add_0_l. - generalize Hz2; clear Hz2; unfold interp_carry. - repeat (rewrite spec_w_sub || rewrite spec_w_mul_c). - repeat rewrite Zmod_small; auto with zarith; try (ring; fail). - match goal with |- context[ww_add_c ?x ?y] => - generalize (spec_ww_add_c x y); case (ww_add_c x y); try rewrite spec_w_1; - intros z1 Hz2 - end. - simpl in Hz2; rewrite Hz2; repeat (rewrite spec_w_sub || rewrite spec_w_mul_c). - repeat rewrite Zmod_small; auto with zarith; try (ring; fail). - rewrite spec_w_2; unfold interp_carry in Hz2. - transitivity (wwB + (1 * wwB + [[z1]])). - ring. - rewrite Hz2; repeat (rewrite spec_w_sub || rewrite spec_w_mul_c). - repeat rewrite Zmod_small; auto with zarith; try (ring; fail). - rewrite spec_w_compare; case Z.compare_spec; intros Hylh; - try rewrite Hylh; try rewrite spec_w_1; try (ring; fail). - match goal with |- context[ww_add_c ?x ?y] => - generalize (spec_ww_add_c x y); case (ww_add_c x y); try rewrite spec_w_1; - intros z1 Hz2 - end. - simpl in Hz2; rewrite Hz2; repeat (rewrite spec_w_sub || rewrite spec_w_mul_c). - repeat rewrite Zmod_small; auto with zarith; try (ring; fail). - rewrite spec_w_2; unfold interp_carry in Hz2. - transitivity (wwB + (1 * wwB + [[z1]])). - ring. - rewrite Hz2; repeat (rewrite spec_w_sub || rewrite spec_w_mul_c). - repeat rewrite Zmod_small; auto with zarith; try (ring; fail). - match goal with |- context[ww_sub_c ?x ?y] => - generalize (spec_ww_sub_c x y); case (ww_sub_c x y); try rewrite spec_w_1; - intros z1 Hz2 - end. - simpl in Hz2; rewrite Hz2; repeat (rewrite spec_w_sub || rewrite spec_w_mul_c). - repeat rewrite Zmod_small; auto with zarith; try (ring; fail). - rewrite spec_w_0; rewrite Z.mul_0_l; rewrite Z.add_0_l. - match goal with |- context[(?x - ?y) * (?z - ?t)] => - replace ((x - y) * (z - t)) with ((y - x) * (t - z)); [idtac | ring] - end. - generalize Hz2; clear Hz2; unfold interp_carry. - repeat (rewrite spec_w_sub || rewrite spec_w_mul_c). - repeat rewrite Zmod_small; auto with zarith; try (ring; fail). - Qed. - - Lemma sub_carry : forall xh xl yh yl z, - 0 <= z -> - [|xh|]*[|yl|] + [|xl|]*[|yh|] = wwB + z -> - z < wwB. - Proof. - intros xh xl yh yl z Hle Heq. - destruct (Z_le_gt_dec wwB z);auto with zarith. - generalize (Zmult_lt_b _ _ _ (spec_to_Z xh) (spec_to_Z yl)). - generalize (Zmult_lt_b _ _ _ (spec_to_Z xl) (spec_to_Z yh)). - rewrite <- wwB_wBwB;intros H1 H2. - assert (H3 := wB_pos w_digits). - assert (2*wB <= wwB). - rewrite wwB_wBwB; rewrite Z.pow_2_r; apply Z.mul_le_mono_nonneg;zarith. - omega. - Qed. - - Ltac Spec_ww_to_Z x := - let H:= fresh "H" in - assert (H:= spec_ww_to_Z x). - - Ltac Zmult_lt_b x y := - let H := fresh "H" in - assert (H := Zmult_lt_b _ _ _ (spec_to_Z x) (spec_to_Z y)). - - Lemma spec_ww_karatsuba_c : forall x y, [||ww_karatsuba_c x y||]=[[x]]*[[y]]. - Proof. - intros x y; unfold ww_karatsuba_c;apply spec_double_mul_c. - intros; apply spec_kara_prod; auto. - Qed. - - Lemma spec_ww_mul : forall x y, [[ww_mul x y]] = [[x]]*[[y]] mod wwB. - Proof. - assert (U:= lt_0_wB w_digits). - assert (U1:= lt_0_wwB w_digits). - intros x y; case x; auto; intros xh xl. - case y; auto. - simpl; rewrite Z.mul_0_r; rewrite Zmod_small; auto with zarith. - intros yh yl;simpl. - repeat (rewrite spec_ww_add || rewrite spec_w_W0 || rewrite spec_w_mul_c - || rewrite spec_w_add || rewrite spec_w_mul). - rewrite <- Zplus_mod; auto with zarith. - repeat (rewrite Z.mul_add_distr_r || rewrite Z.mul_add_distr_l). - rewrite <- Zmult_mod_distr_r; auto with zarith. - rewrite <- Z.pow_2_r; rewrite <- wwB_wBwB; auto with zarith. - rewrite Zplus_mod; auto with zarith. - rewrite Zmod_mod; auto with zarith. - rewrite <- Zplus_mod; auto with zarith. - match goal with |- ?X mod _ = _ => - rewrite <- Z_mod_plus with (a := X) (b := [|xh|] * [|yh|]) - end; auto with zarith. - f_equal; auto; rewrite wwB_wBwB; ring. - Qed. - - Lemma spec_ww_square_c : forall x, [||ww_square_c x||] = [[x]]*[[x]]. - Proof. - destruct x as [ |xh xl];simpl;trivial. - case_eq match ww_add_c (w_mul_c xh xl) (w_mul_c xh xl) with - | C0 cc => (w_0, cc) - | C1 cc => (w_1, cc) - end;intros wc cc Heq. - apply (spec_mul_aux xh xl xh xl wc cc);trivial. - generalize Heq (spec_ww_add_c (w_mul_c xh xl) (w_mul_c xh xl));clear Heq. - rewrite spec_w_mul_c;destruct (ww_add_c (w_mul_c xh xl) (w_mul_c xh xl)); - unfold interp_carry;try rewrite Z.mul_1_l;intros Heq Heq';inversion Heq; - rewrite (Z.mul_comm [|xl|]);subst. - rewrite spec_w_0;rewrite Z.mul_0_l;rewrite Z.add_0_l;trivial. - rewrite spec_w_1;rewrite Z.mul_1_l;rewrite <- wwB_wBwB;trivial. - Qed. - - Section DoubleMulAddn1Proof. - - Variable w_mul_add : w -> w -> w -> w * w. - Variable spec_w_mul_add : forall x y r, - let (h,l):= w_mul_add x y r in - [|h|]*wB+[|l|] = [|x|]*[|y|] + [|r|]. - - Lemma spec_double_mul_add_n1 : forall n x y r, - let (h,l) := double_mul_add_n1 w_mul_add n x y r in - [|h|]*double_wB w_digits n + [!n|l!] = [!n|x!]*[|y|]+[|r|]. - Proof. - induction n;intros x y r;trivial. - exact (spec_w_mul_add x y r). - unfold double_mul_add_n1;destruct x as[ |xh xl]; - fold(double_mul_add_n1 w_mul_add). - rewrite spec_w_0;rewrite spec_extend;simpl;trivial. - assert(H:=IHn xl y r);destruct (double_mul_add_n1 w_mul_add n xl y r)as(rl,l). - assert(U:=IHn xh y rl);destruct(double_mul_add_n1 w_mul_add n xh y rl)as(rh,h). - rewrite <- double_wB_wwB. rewrite spec_double_WW;simpl;trivial. - rewrite Z.mul_add_distr_r;rewrite <- Z.add_assoc;rewrite <- H. - rewrite Z.mul_assoc;rewrite Z.add_assoc;rewrite <- Z.mul_add_distr_r. - rewrite U;ring. - Qed. - - End DoubleMulAddn1Proof. - - Lemma spec_w_mul_add : forall x y r, - let (h,l):= w_mul_add x y r in - [|h|]*wB+[|l|] = [|x|]*[|y|] + [|r|]. - Proof. - intros x y r;unfold w_mul_add;assert (H:=spec_w_mul_c x y); - destruct (w_mul_c x y) as [ |h l];simpl;rewrite <- H. - rewrite spec_w_0;trivial. - assert (U:=spec_w_add_c l r);destruct (w_add_c l r) as [lr|lr];unfold - interp_carry in U;try rewrite Z.mul_1_l in H;simpl. - rewrite U;ring. rewrite spec_w_succ. rewrite Zmod_small. - rewrite <- Z.add_assoc;rewrite <- U;ring. - simpl in H;assert (H1:= Zmult_lt_b _ _ _ (spec_to_Z x) (spec_to_Z y)). - rewrite <- H in H1. - assert (H2:=spec_to_Z h);split;zarith. - case H1;clear H1;intro H1;clear H1. - replace (wB ^ 2 - 2 * wB) with ((wB - 2)*wB). 2:ring. - intros H0;assert (U1:= wB_pos w_digits). - assert (H1 := beta_lex _ _ _ _ _ H0 (spec_to_Z l));zarith. - Qed. - -(* End DoubleProof. *) - -End DoubleMul. diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleSqrt.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleSqrt.v deleted file mode 100644 index d07ce30189..0000000000 --- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleSqrt.v +++ /dev/null @@ -1,1369 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) -(* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) -(************************************************************************) - -Set Implicit Arguments. - -Require Import ZArith. -Require Import BigNumPrelude. -Require Import DoubleType. -Require Import DoubleBase. - -Local Open Scope Z_scope. - -Section DoubleSqrt. - Variable w : Type. - Variable w_is_even : w -> bool. - Variable w_compare : w -> w -> comparison. - Variable w_0 : w. - Variable w_1 : w. - Variable w_Bm1 : w. - Variable w_WW : w -> w -> zn2z w. - Variable w_W0 : w -> zn2z w. - Variable w_0W : w -> zn2z w. - Variable w_sub : w -> w -> w. - Variable w_sub_c : w -> w -> carry w. - Variable w_square_c : w -> zn2z w. - Variable w_div21 : w -> w -> w -> w * w. - Variable w_add_mul_div : w -> w -> w -> w. - Variable w_digits : positive. - Variable w_zdigits : w. - Variable ww_zdigits : zn2z w. - Variable w_add_c : w -> w -> carry w. - Variable w_sqrt2 : w -> w -> w * carry w. - Variable w_pred : w -> w. - Variable ww_pred_c : zn2z w -> carry (zn2z w). - Variable ww_pred : zn2z w -> zn2z w. - Variable ww_add_c : zn2z w -> zn2z w -> carry (zn2z w). - Variable ww_add : zn2z w -> zn2z w -> zn2z w. - Variable ww_sub_c : zn2z w -> zn2z w -> carry (zn2z w). - Variable ww_add_mul_div : zn2z w -> zn2z w -> zn2z w -> zn2z w. - Variable ww_head0 : zn2z w -> zn2z w. - Variable ww_compare : zn2z w -> zn2z w -> comparison. - Variable low : zn2z w -> w. - - Let wwBm1 := ww_Bm1 w_Bm1. - - Definition ww_is_even x := - match x with - | W0 => true - | WW xh xl => w_is_even xl - end. - - Let w_div21c x y z := - match w_compare x z with - | Eq => - match w_compare y z with - Eq => (C1 w_1, w_0) - | Gt => (C1 w_1, w_sub y z) - | Lt => (C1 w_0, y) - end - | Gt => - let x1 := w_sub x z in - let (q, r) := w_div21 x1 y z in - (C1 q, r) - | Lt => - let (q, r) := w_div21 x y z in - (C0 q, r) - end. - - Let w_div2s x y s := - match x with - C1 x1 => - let x2 := w_sub x1 s in - let (q, r) := w_div21c x2 y s in - match q with - C0 q1 => - if w_is_even q1 then - (C0 (w_add_mul_div (w_pred w_zdigits) w_1 q1), C0 r) - else - (C0 (w_add_mul_div (w_pred w_zdigits) w_1 q1), w_add_c r s) - | C1 q1 => - if w_is_even q1 then - (C1 (w_add_mul_div (w_pred w_zdigits) w_0 q1), C0 r) - else - (C1 (w_add_mul_div (w_pred w_zdigits) w_0 q1), w_add_c r s) - end - | C0 x1 => - let (q, r) := w_div21c x1 y s in - match q with - C0 q1 => - if w_is_even q1 then - (C0 (w_add_mul_div (w_pred w_zdigits) w_0 q1), C0 r) - else - (C0 (w_add_mul_div (w_pred w_zdigits) w_0 q1), w_add_c r s) - | C1 q1 => - if w_is_even q1 then - (C0 (w_add_mul_div (w_pred w_zdigits) w_1 q1), C0 r) - else - (C0 (w_add_mul_div (w_pred w_zdigits) w_1 q1), w_add_c r s) - end - end. - - Definition split x := - match x with - | W0 => (w_0,w_0) - | WW h l => (h,l) - end. - - Definition ww_sqrt2 x y := - let (x1, x2) := split x in - let (y1, y2) := split y in - let ( q, r) := w_sqrt2 x1 x2 in - let (q1, r1) := w_div2s r y1 q in - match q1 with - C0 q1 => - let q2 := w_square_c q1 in - let a := WW q q1 in - match r1 with - C1 r2 => - match ww_sub_c (WW r2 y2) q2 with - C0 r3 => (a, C1 r3) - | C1 r3 => (a, C0 r3) - end - | C0 r2 => - match ww_sub_c (WW r2 y2) q2 with - C0 r3 => (a, C0 r3) - | C1 r3 => - let a2 := ww_add_mul_div (w_0W w_1) a W0 in - match ww_pred_c a2 with - C0 a3 => - (ww_pred a, ww_add_c a3 r3) - | C1 a3 => - (ww_pred a, C0 (ww_add a3 r3)) - end - end - end - | C1 q1 => - let a1 := WW q w_Bm1 in - let a2 := ww_add_mul_div (w_0W w_1) a1 wwBm1 in - (a1, ww_add_c a2 y) - end. - - Definition ww_is_zero x := - match ww_compare W0 x with - Eq => true - | _ => false - end. - - Definition ww_head1 x := - let p := ww_head0 x in - if (ww_is_even p) then p else ww_pred p. - - Definition ww_sqrt x := - if (ww_is_zero x) then W0 - else - let p := ww_head1 x in - match ww_compare p W0 with - | Gt => - match ww_add_mul_div p x W0 with - W0 => W0 - | WW x1 x2 => - let (r, _) := w_sqrt2 x1 x2 in - WW w_0 (w_add_mul_div - (w_sub w_zdigits - (low (ww_add_mul_div (ww_pred ww_zdigits) - W0 p))) w_0 r) - end - | _ => - match x with - W0 => W0 - | WW x1 x2 => WW w_0 (fst (w_sqrt2 x1 x2)) - end - end. - - - Variable w_to_Z : w -> Z. - - Notation wB := (base w_digits). - Notation wwB := (base (ww_digits w_digits)). - Notation "[| x |]" := (w_to_Z x) (at level 0, x at level 99). - Notation "[+| c |]" := - (interp_carry 1 wB w_to_Z c) (at level 0, c at level 99). - Notation "[-| c |]" := - (interp_carry (-1) wB w_to_Z c) (at level 0, c at level 99). - - Notation "[[ x ]]" := (ww_to_Z w_digits w_to_Z x)(at level 0, x at level 99). - Notation "[+[ c ]]" := - (interp_carry 1 wwB (ww_to_Z w_digits w_to_Z) c) - (at level 0, c at level 99). - Notation "[-[ c ]]" := - (interp_carry (-1) wwB (ww_to_Z w_digits w_to_Z) c) - (at level 0, c at level 99). - - Notation "[|| x ||]" := - (zn2z_to_Z wwB (ww_to_Z w_digits w_to_Z) x) (at level 0, x at level 99). - - Notation "[! n | x !]" := (double_to_Z w_digits w_to_Z n x) - (at level 0, x at level 99). - - Variable spec_w_0 : [|w_0|] = 0. - Variable spec_w_1 : [|w_1|] = 1. - Variable spec_w_Bm1 : [|w_Bm1|] = wB - 1. - Variable spec_w_zdigits : [|w_zdigits|] = Zpos w_digits. - Variable spec_more_than_1_digit: 1 < Zpos w_digits. - - Variable spec_ww_zdigits : [[ww_zdigits]] = Zpos (xO w_digits). - Variable spec_to_Z : forall x, 0 <= [|x|] < wB. - Variable spec_to_w_Z : forall x, 0 <= [[x]] < wwB. - - Variable spec_w_WW : forall h l, [[w_WW h l]] = [|h|] * wB + [|l|]. - Variable spec_w_W0 : forall h, [[w_W0 h]] = [|h|] * wB. - Variable spec_w_0W : forall l, [[w_0W l]] = [|l|]. - Variable spec_w_is_even : forall x, - if w_is_even x then [|x|] mod 2 = 0 else [|x|] mod 2 = 1. - Variable spec_w_compare : forall x y, - w_compare x y = Z.compare [|x|] [|y|]. - Variable spec_w_sub : forall x y, [|w_sub x y|] = ([|x|] - [|y|]) mod wB. - Variable spec_w_square_c : forall x, [[ w_square_c x]] = [|x|] * [|x|]. - Variable spec_w_div21 : forall a1 a2 b, - wB/2 <= [|b|] -> - [|a1|] < [|b|] -> - let (q,r) := w_div21 a1 a2 b in - [|a1|] *wB+ [|a2|] = [|q|] * [|b|] + [|r|] /\ - 0 <= [|r|] < [|b|]. - Variable spec_w_add_mul_div : forall x y p, - [|p|] <= Zpos w_digits -> - [| w_add_mul_div p x y |] = - ([|x|] * (2 ^ [|p|]) + - [|y|] / (Z.pow 2 ((Zpos w_digits) - [|p|]))) mod wB. - Variable spec_ww_add_mul_div : forall x y p, - [[p]] <= Zpos (xO w_digits) -> - [[ ww_add_mul_div p x y ]] = - ([[x]] * (2^ [[p]]) + - [[y]] / (2^ (Zpos (xO w_digits) - [[p]]))) mod wwB. - Variable spec_w_add_c : forall x y, [+|w_add_c x y|] = [|x|] + [|y|]. - Variable spec_ww_add : forall x y, [[ww_add x y]] = ([[x]] + [[y]]) mod wwB. - Variable spec_w_sqrt2 : forall x y, - wB/ 4 <= [|x|] -> - let (s,r) := w_sqrt2 x y in - [[WW x y]] = [|s|] ^ 2 + [+|r|] /\ - [+|r|] <= 2 * [|s|]. - Variable spec_ww_sub_c : forall x y, [-[ww_sub_c x y]] = [[x]] - [[y]]. - Variable spec_ww_pred_c : forall x, [-[ww_pred_c x]] = [[x]] - 1. - Variable spec_pred : forall x, [|w_pred x|] = ([|x|] - 1) mod wB. - Variable spec_ww_pred : forall x, [[ww_pred x]] = ([[x]] - 1) mod wwB. - Variable spec_ww_add_c : forall x y, [+[ww_add_c x y]] = [[x]] + [[y]]. - Variable spec_ww_compare : forall x y, - ww_compare x y = Z.compare [[x]] [[y]]. - Variable spec_ww_head0 : forall x, 0 < [[x]] -> - wwB/ 2 <= 2 ^ [[ww_head0 x]] * [[x]] < wwB. - Variable spec_low: forall x, [|low x|] = [[x]] mod wB. - - Let spec_ww_Bm1 : [[wwBm1]] = wwB - 1. - Proof. refine (spec_ww_Bm1 w_Bm1 w_digits w_to_Z _);auto. Qed. - - Hint Rewrite spec_w_0 spec_w_1 spec_w_WW spec_w_sub - spec_w_add_mul_div spec_ww_Bm1 spec_w_add_c : w_rewrite. - - Lemma spec_ww_is_even : forall x, - if ww_is_even x then [[x]] mod 2 = 0 else [[x]] mod 2 = 1. -clear spec_more_than_1_digit. -intros x; case x; simpl ww_is_even. - reflexivity. - simpl. - intros w1 w2; simpl. - unfold base. - rewrite Zplus_mod; auto with zarith. - rewrite (fun x y => (Zdivide_mod (x * y))); auto with zarith. - rewrite Z.add_0_l; rewrite Zmod_mod; auto with zarith. - apply spec_w_is_even; auto with zarith. - apply Z.divide_mul_r; apply Zpower_divide; auto with zarith. - Qed. - - - Theorem spec_w_div21c : forall a1 a2 b, - wB/2 <= [|b|] -> - let (q,r) := w_div21c a1 a2 b in - [|a1|] * wB + [|a2|] = [+|q|] * [|b|] + [|r|] /\ 0 <= [|r|] < [|b|]. - intros a1 a2 b Hb; unfold w_div21c. - assert (H: 0 < [|b|]); auto with zarith. - assert (U := wB_pos w_digits). - apply Z.lt_le_trans with (2 := Hb); auto with zarith. - apply Z.lt_le_trans with 1; auto with zarith. - apply Zdiv_le_lower_bound; auto with zarith. - rewrite !spec_w_compare. repeat case Z.compare_spec. - intros H1 H2; split. - unfold interp_carry; autorewrite with w_rewrite rm10; auto with zarith. - rewrite H1; rewrite H2; ring. - autorewrite with w_rewrite; auto with zarith. - intros H1 H2; split. - unfold interp_carry; autorewrite with w_rewrite rm10; auto with zarith. - rewrite H2; ring. - destruct (spec_to_Z a2);auto with zarith. - intros H1 H2; split. - unfold interp_carry; autorewrite with w_rewrite rm10; auto with zarith. - rewrite H2; rewrite Zmod_small; auto with zarith. - ring. - destruct (spec_to_Z a2);auto with zarith. - rewrite spec_w_sub; auto with zarith. - destruct (spec_to_Z a2) as [H3 H4];auto with zarith. - rewrite Zmod_small; auto with zarith. - split; auto with zarith. - assert ([|a2|] < 2 * [|b|]); auto with zarith. - apply Z.lt_le_trans with (2 * (wB / 2)); auto with zarith. - rewrite wB_div_2; auto. - intros H1. - match goal with |- context[w_div21 ?y ?z ?t] => - generalize (@spec_w_div21 y z t Hb H1); - case (w_div21 y z t); simpl; autorewrite with w_rewrite; - auto - end. - intros H1. - assert (H2: [|w_sub a1 b|] < [|b|]). - rewrite spec_w_sub; auto with zarith. - rewrite Zmod_small; auto with zarith. - assert ([|a1|] < 2 * [|b|]); auto with zarith. - apply Z.lt_le_trans with (2 * (wB / 2)); auto with zarith. - rewrite wB_div_2; auto. - destruct (spec_to_Z a1);auto with zarith. - destruct (spec_to_Z a1);auto with zarith. - match goal with |- context[w_div21 ?y ?z ?t] => - generalize (@spec_w_div21 y z t Hb H2); - case (w_div21 y z t); autorewrite with w_rewrite; - auto - end. - intros w0 w1; replace [+|C1 w0|] with (wB + [|w0|]). - rewrite Zmod_small; auto with zarith. - intros (H3, H4); split; auto. - rewrite Z.mul_add_distr_r. - rewrite <- Z.add_assoc; rewrite <- H3; ring. - split; auto with zarith. - assert ([|a1|] < 2 * [|b|]); auto with zarith. - apply Z.lt_le_trans with (2 * (wB / 2)); auto with zarith. - rewrite wB_div_2; auto. - destruct (spec_to_Z a1);auto with zarith. - destruct (spec_to_Z a1);auto with zarith. - simpl; case wB; auto. - Qed. - - Theorem C0_id: forall p, [+|C0 p|] = [|p|]. - intros p; simpl; auto. - Qed. - - Theorem add_mult_div_2: forall w, - [|w_add_mul_div (w_pred w_zdigits) w_0 w|] = [|w|] / 2. - intros w1. - assert (Hp: [|w_pred w_zdigits|] = Zpos w_digits - 1). - rewrite spec_pred; rewrite spec_w_zdigits. - rewrite Zmod_small; auto with zarith. - split; auto with zarith. - apply Z.lt_le_trans with (Zpos w_digits); auto with zarith. - unfold base; apply Zpower2_le_lin; auto with zarith. - rewrite spec_w_add_mul_div; auto with zarith. - autorewrite with w_rewrite rm10. - match goal with |- context[?X - ?Y] => - replace (X - Y) with 1 - end. - rewrite Z.pow_1_r; rewrite Zmod_small; auto with zarith. - destruct (spec_to_Z w1) as [H1 H2];auto with zarith. - split; auto with zarith. - apply Zdiv_lt_upper_bound; auto with zarith. - rewrite Hp; ring. - Qed. - - Theorem add_mult_div_2_plus_1: forall w, - [|w_add_mul_div (w_pred w_zdigits) w_1 w|] = - [|w|] / 2 + 2 ^ Zpos (w_digits - 1). - intros w1. - assert (Hp: [|w_pred w_zdigits|] = Zpos w_digits - 1). - rewrite spec_pred; rewrite spec_w_zdigits. - rewrite Zmod_small; auto with zarith. - split; auto with zarith. - apply Z.lt_le_trans with (Zpos w_digits); auto with zarith. - unfold base; apply Zpower2_le_lin; auto with zarith. - autorewrite with w_rewrite rm10; auto with zarith. - match goal with |- context[?X - ?Y] => - replace (X - Y) with 1 - end; rewrite Hp; try ring. - rewrite Pos2Z.inj_sub_max; auto with zarith. - rewrite Z.max_r; auto with zarith. - rewrite Z.pow_1_r; rewrite Zmod_small; auto with zarith. - destruct (spec_to_Z w1) as [H1 H2];auto with zarith. - split; auto with zarith. - unfold base. - match goal with |- _ < _ ^ ?X => - assert (tmp: forall p, 1 + (p - 1) = p); auto with zarith; - rewrite <- (tmp X); clear tmp - end. - rewrite Zpower_exp; try rewrite Z.pow_1_r; auto with zarith. - assert (tmp: forall p, 1 + (p -1) - 1 = p - 1); auto with zarith; - rewrite tmp; clear tmp; auto with zarith. - match goal with |- ?X + ?Y < _ => - assert (Y < X); auto with zarith - end. - apply Zdiv_lt_upper_bound; auto with zarith. - pattern 2 at 2; rewrite <- Z.pow_1_r; rewrite <- Zpower_exp; - auto with zarith. - assert (tmp: forall p, (p - 1) + 1 = p); auto with zarith; - rewrite tmp; clear tmp; auto with zarith. - Qed. - - Theorem add_mult_mult_2: forall w, - [|w_add_mul_div w_1 w w_0|] = 2 * [|w|] mod wB. - intros w1. - autorewrite with w_rewrite rm10; auto with zarith. - rewrite Z.pow_1_r; auto with zarith. - rewrite Z.mul_comm; auto. - Qed. - - Theorem ww_add_mult_mult_2: forall w, - [[ww_add_mul_div (w_0W w_1) w W0]] = 2 * [[w]] mod wwB. - intros w1. - rewrite spec_ww_add_mul_div; auto with zarith. - autorewrite with w_rewrite rm10. - rewrite spec_w_0W; rewrite spec_w_1. - rewrite Z.pow_1_r; auto with zarith. - rewrite Z.mul_comm; auto. - rewrite spec_w_0W; rewrite spec_w_1; auto with zarith. - red; simpl; intros; discriminate. - Qed. - - Theorem ww_add_mult_mult_2_plus_1: forall w, - [[ww_add_mul_div (w_0W w_1) w wwBm1]] = - (2 * [[w]] + 1) mod wwB. - intros w1. - rewrite spec_ww_add_mul_div; auto with zarith. - rewrite spec_w_0W; rewrite spec_w_1; auto with zarith. - rewrite Z.pow_1_r; auto with zarith. - f_equal; auto. - rewrite Z.mul_comm; f_equal; auto. - autorewrite with w_rewrite rm10. - unfold ww_digits, base. - symmetry; apply Zdiv_unique with (r := 2 ^ (Zpos (ww_digits w_digits) - 1) -1); - auto with zarith. - unfold ww_digits; split; auto with zarith. - match goal with |- 0 <= ?X - 1 => - assert (0 < X); auto with zarith - end. - apply Z.pow_pos_nonneg; auto with zarith. - match goal with |- 0 <= ?X - 1 => - assert (0 < X); auto with zarith; red; reflexivity - end. - unfold ww_digits; autorewrite with rm10. - assert (tmp: forall p q r, p + (q - r) = p + q - r); auto with zarith; - rewrite tmp; clear tmp. - assert (tmp: forall p, p + p = 2 * p); auto with zarith; - rewrite tmp; clear tmp. - f_equal; auto. - pattern 2 at 2; rewrite <- Z.pow_1_r; rewrite <- Zpower_exp; - auto with zarith. - assert (tmp: forall p, 1 + (p - 1) = p); auto with zarith; - rewrite tmp; clear tmp; auto. - match goal with |- ?X - 1 >= 0 => - assert (0 < X); auto with zarith; red; reflexivity - end. - rewrite spec_w_0W; rewrite spec_w_1; auto with zarith. - red; simpl; intros; discriminate. - Qed. - - Theorem Zplus_mod_one: forall a1 b1, 0 < b1 -> (a1 + b1) mod b1 = a1 mod b1. - intros a1 b1 H; rewrite Zplus_mod; auto with zarith. - rewrite Z_mod_same; try rewrite Z.add_0_r; auto with zarith. - apply Zmod_mod; auto. - Qed. - - Lemma C1_plus_wB: forall x, [+|C1 x|] = wB + [|x|]. - unfold interp_carry; auto with zarith. - Qed. - - Theorem spec_w_div2s : forall a1 a2 b, - wB/2 <= [|b|] -> [+|a1|] <= 2 * [|b|] -> - let (q,r) := w_div2s a1 a2 b in - [+|a1|] * wB + [|a2|] = [+|q|] * (2 * [|b|]) + [+|r|] /\ 0 <= [+|r|] < 2 * [|b|]. - intros a1 a2 b H. - assert (HH: 0 < [|b|]); auto with zarith. - assert (U := wB_pos w_digits). - apply Z.lt_le_trans with (2 := H); auto with zarith. - apply Z.lt_le_trans with 1; auto with zarith. - apply Zdiv_le_lower_bound; auto with zarith. - unfold w_div2s; case a1; intros w0 H0. - match goal with |- context[w_div21c ?y ?z ?t] => - generalize (@spec_w_div21c y z t H); - case (w_div21c y z t); autorewrite with w_rewrite; - auto - end. - intros c w1; case c. - simpl interp_carry; intros w2 (Hw1, Hw2). - match goal with |- context[w_is_even ?y] => - generalize (spec_w_is_even y); - case (w_is_even y) - end. - repeat rewrite C0_id. - rewrite add_mult_div_2. - intros H1; split; auto with zarith. - rewrite Hw1. - pattern [|w2|] at 1; rewrite (Z_div_mod_eq [|w2|] 2); - auto with zarith. - rewrite H1; ring. - repeat rewrite C0_id. - rewrite add_mult_div_2. - rewrite spec_w_add_c; auto with zarith. - intros H1; split; auto with zarith. - rewrite Hw1. - pattern [|w2|] at 1; rewrite (Z_div_mod_eq [|w2|] 2); - auto with zarith. - rewrite H1; ring. - intros w2; rewrite C1_plus_wB. - intros (Hw1, Hw2). - match goal with |- context[w_is_even ?y] => - generalize (spec_w_is_even y); - case (w_is_even y) - end. - repeat rewrite C0_id. - intros H1; split; auto with zarith. - rewrite Hw1. - pattern [|w2|] at 1; rewrite (Z_div_mod_eq [|w2|] 2); - auto with zarith. - rewrite H1. - repeat rewrite C0_id. - rewrite add_mult_div_2_plus_1; unfold base. - match goal with |- context[_ ^ ?X] => - assert (tmp: forall p, 1 + (p - 1) = p); auto with zarith; - rewrite <- (tmp X); clear tmp; rewrite Zpower_exp; - try rewrite Z.pow_1_r; auto with zarith - end. - rewrite Pos2Z.inj_sub_max; auto with zarith. - rewrite Z.max_r; auto with zarith. - ring. - repeat rewrite C0_id. - rewrite spec_w_add_c; auto with zarith. - intros H1; split; auto with zarith. - rewrite add_mult_div_2_plus_1. - rewrite Hw1. - pattern [|w2|] at 1; rewrite (Z_div_mod_eq [|w2|] 2); - auto with zarith. - rewrite H1. - unfold base. - match goal with |- context[_ ^ ?X] => - assert (tmp: forall p, 1 + (p - 1) = p); auto with zarith; - rewrite <- (tmp X); clear tmp; rewrite Zpower_exp; - try rewrite Z.pow_1_r; auto with zarith - end. - rewrite Pos2Z.inj_sub_max; auto with zarith. - rewrite Z.max_r; auto with zarith. - ring. - repeat rewrite C1_plus_wB in H0. - rewrite C1_plus_wB. - match goal with |- context[w_div21c ?y ?z ?t] => - generalize (@spec_w_div21c y z t H); - case (w_div21c y z t); autorewrite with w_rewrite; - auto - end. - intros c w1; case c. - intros w2 (Hw1, Hw2); rewrite C0_id in Hw1. - rewrite <- Zplus_mod_one in Hw1; auto with zarith. - rewrite Zmod_small in Hw1; auto with zarith. - match goal with |- context[w_is_even ?y] => - generalize (spec_w_is_even y); - case (w_is_even y) - end. - repeat rewrite C0_id. - intros H1; split; auto with zarith. - rewrite add_mult_div_2_plus_1. - replace (wB + [|w0|]) with ([|b|] + ([|w0|] - [|b|] + wB)); - auto with zarith. - rewrite Z.mul_add_distr_r; rewrite <- Z.add_assoc. - rewrite Hw1. - pattern [|w2|] at 1; rewrite (Z_div_mod_eq [|w2|] 2); - auto with zarith. - rewrite H1; unfold base. - match goal with |- context[_ ^ ?X] => - assert (tmp: forall p, 1 + (p - 1) = p); auto with zarith; - rewrite <- (tmp X); clear tmp; rewrite Zpower_exp; - try rewrite Z.pow_1_r; auto with zarith - end. - rewrite Pos2Z.inj_sub_max; auto with zarith. - rewrite Z.max_r; auto with zarith. - ring. - repeat rewrite C0_id. - rewrite add_mult_div_2_plus_1. - rewrite spec_w_add_c; auto with zarith. - intros H1; split; auto with zarith. - replace (wB + [|w0|]) with ([|b|] + ([|w0|] - [|b|] + wB)); - auto with zarith. - rewrite Z.mul_add_distr_r; rewrite <- Z.add_assoc. - rewrite Hw1. - pattern [|w2|] at 1; rewrite (Z_div_mod_eq [|w2|] 2); - auto with zarith. - rewrite H1; unfold base. - match goal with |- context[_ ^ ?X] => - assert (tmp: forall p, 1 + (p - 1) = p); auto with zarith; - rewrite <- (tmp X); clear tmp; rewrite Zpower_exp; - try rewrite Z.pow_1_r; auto with zarith - end. - rewrite Pos2Z.inj_sub_max; auto with zarith. - rewrite Z.max_r; auto with zarith. - ring. - split; auto with zarith. - destruct (spec_to_Z b);auto with zarith. - destruct (spec_to_Z w0);auto with zarith. - destruct (spec_to_Z b);auto with zarith. - destruct (spec_to_Z b);auto with zarith. - intros w2; rewrite C1_plus_wB. - rewrite <- Zplus_mod_one; auto with zarith. - rewrite Zmod_small; auto with zarith. - intros (Hw1, Hw2). - match goal with |- context[w_is_even ?y] => - generalize (spec_w_is_even y); - case (w_is_even y) - end. - repeat (rewrite C0_id || rewrite C1_plus_wB). - intros H1; split; auto with zarith. - rewrite add_mult_div_2. - replace (wB + [|w0|]) with ([|b|] + ([|w0|] - [|b|] + wB)); - auto with zarith. - rewrite Z.mul_add_distr_r; rewrite <- Z.add_assoc. - rewrite Hw1. - pattern [|w2|] at 1; rewrite (Z_div_mod_eq [|w2|] 2); - auto with zarith. - rewrite H1; ring. - repeat (rewrite C0_id || rewrite C1_plus_wB). - rewrite spec_w_add_c; auto with zarith. - intros H1; split; auto with zarith. - rewrite add_mult_div_2. - replace (wB + [|w0|]) with ([|b|] + ([|w0|] - [|b|] + wB)); - auto with zarith. - rewrite Z.mul_add_distr_r; rewrite <- Z.add_assoc. - rewrite Hw1. - pattern [|w2|] at 1; rewrite (Z_div_mod_eq [|w2|] 2); - auto with zarith. - rewrite H1; ring. - split; auto with zarith. - destruct (spec_to_Z b);auto with zarith. - destruct (spec_to_Z w0);auto with zarith. - destruct (spec_to_Z b);auto with zarith. - destruct (spec_to_Z b);auto with zarith. - Qed. - - Theorem wB_div_4: 4 * (wB / 4) = wB. - Proof. - unfold base. - assert (2 ^ Zpos w_digits = - 4 * (2 ^ (Zpos w_digits - 2))). - change 4 with (2 ^ 2). - rewrite <- Zpower_exp; auto with zarith. - f_equal; auto with zarith. - rewrite H. - rewrite (fun x => (Z.mul_comm 4 (2 ^x))). - rewrite Z_div_mult; auto with zarith. - Qed. - - Theorem Zsquare_mult: forall p, p ^ 2 = p * p. - intros p; change 2 with (1 + 1); rewrite Zpower_exp; - try rewrite Z.pow_1_r; auto with zarith. - Qed. - - Theorem Zsquare_pos: forall p, 0 <= p ^ 2. - intros p; case (Z.le_gt_cases 0 p); intros H1. - rewrite Zsquare_mult; apply Z.mul_nonneg_nonneg; auto with zarith. - rewrite Zsquare_mult; replace (p * p) with ((- p) * (- p)); try ring. - apply Z.mul_nonneg_nonneg; auto with zarith. - Qed. - - Lemma spec_split: forall x, - [|fst (split x)|] * wB + [|snd (split x)|] = [[x]]. - intros x; case x; simpl; autorewrite with w_rewrite; - auto with zarith. - Qed. - - Theorem mult_wwB: forall x y, [|x|] * [|y|] < wwB. - Proof. - intros x y; rewrite wwB_wBwB; rewrite Z.pow_2_r. - generalize (spec_to_Z x); intros U. - generalize (spec_to_Z y); intros U1. - apply Z.le_lt_trans with ((wB -1 ) * (wB - 1)); auto with zarith. - apply Z.mul_le_mono_nonneg; auto with zarith. - rewrite ?Z.mul_sub_distr_l, ?Z.mul_sub_distr_r; auto with zarith. - Qed. - Hint Resolve mult_wwB. - - Lemma spec_ww_sqrt2 : forall x y, - wwB/ 4 <= [[x]] -> - let (s,r) := ww_sqrt2 x y in - [||WW x y||] = [[s]] ^ 2 + [+[r]] /\ - [+[r]] <= 2 * [[s]]. - intros x y H; unfold ww_sqrt2. - repeat match goal with |- context[split ?x] => - generalize (spec_split x); case (split x) - end; simpl @fst; simpl @snd. - intros w0 w1 Hw0 w2 w3 Hw1. - assert (U: wB/4 <= [|w2|]). - case (Z.le_gt_cases (wB / 4) [|w2|]); auto; intros H1. - contradict H; apply Z.lt_nge. - rewrite wwB_wBwB; rewrite Z.pow_2_r. - pattern wB at 1; rewrite <- wB_div_4; rewrite <- Z.mul_assoc; - rewrite Z.mul_comm. - rewrite Z_div_mult; auto with zarith. - rewrite <- Hw1. - match goal with |- _ < ?X => - pattern X; rewrite <- Z.add_0_r; apply beta_lex_inv; - auto with zarith - end. - destruct (spec_to_Z w3);auto with zarith. - generalize (@spec_w_sqrt2 w2 w3 U); case (w_sqrt2 w2 w3). - intros w4 c (H1, H2). - assert (U1: wB/2 <= [|w4|]). - case (Z.le_gt_cases (wB/2) [|w4|]); auto with zarith. - intros U1. - assert (U2 : [|w4|] <= wB/2 -1); auto with zarith. - assert (U3 : [|w4|] ^ 2 <= wB/4 * wB - wB + 1); auto with zarith. - match goal with |- ?X ^ 2 <= ?Y => - rewrite Zsquare_mult; - replace Y with ((wB/2 - 1) * (wB/2 -1)) - end. - apply Z.mul_le_mono_nonneg; auto with zarith. - destruct (spec_to_Z w4);auto with zarith. - destruct (spec_to_Z w4);auto with zarith. - pattern wB at 4 5; rewrite <- wB_div_2. - rewrite Z.mul_assoc. - replace ((wB / 4) * 2) with (wB / 2). - ring. - pattern wB at 1; rewrite <- wB_div_4. - change 4 with (2 * 2). - rewrite <- Z.mul_assoc; rewrite (Z.mul_comm 2). - rewrite Z_div_mult; try ring; auto with zarith. - assert (U4 : [+|c|] <= wB -2); auto with zarith. - apply Z.le_trans with (1 := H2). - match goal with |- ?X <= ?Y => - replace Y with (2 * (wB/ 2 - 1)); auto with zarith - end. - pattern wB at 2; rewrite <- wB_div_2; auto with zarith. - match type of H1 with ?X = _ => - assert (U5: X < wB / 4 * wB) - end. - rewrite H1; auto with zarith. - contradict U; apply Z.lt_nge. - apply Z.mul_lt_mono_pos_r with wB; auto with zarith. - destruct (spec_to_Z w4);auto with zarith. - apply Z.le_lt_trans with (2 := U5). - unfold ww_to_Z, zn2z_to_Z. - destruct (spec_to_Z w3);auto with zarith. - generalize (@spec_w_div2s c w0 w4 U1 H2). - case (w_div2s c w0 w4). - intros c0; case c0; intros w5; - repeat (rewrite C0_id || rewrite C1_plus_wB). - intros c1; case c1; intros w6; - repeat (rewrite C0_id || rewrite C1_plus_wB). - intros (H3, H4). - match goal with |- context [ww_sub_c ?y ?z] => - generalize (spec_ww_sub_c y z); case (ww_sub_c y z) - end. - intros z; change [-[C0 z]] with ([[z]]). - change [+[C0 z]] with ([[z]]). - intros H5; rewrite spec_w_square_c in H5; - auto. - split. - unfold zn2z_to_Z; rewrite <- Hw1. - unfold ww_to_Z, zn2z_to_Z in H1. rewrite H1. - rewrite <- Hw0. - match goal with |- (?X ^2 + ?Y) * wwB + (?Z * wB + ?T) = ?U => - transitivity ((X * wB) ^ 2 + (Y * wB + Z) * wB + T) - end. - repeat rewrite Zsquare_mult. - rewrite wwB_wBwB; ring. - rewrite H3. - rewrite H5. - unfold ww_to_Z, zn2z_to_Z. - repeat rewrite Zsquare_mult; ring. - rewrite H5. - unfold ww_to_Z, zn2z_to_Z. - match goal with |- ?X - ?Y * ?Y <= _ => - assert (V := Zsquare_pos Y); - rewrite Zsquare_mult in V; - apply Z.le_trans with X; auto with zarith; - clear V - end. - match goal with |- ?X * wB + ?Y <= 2 * (?Z * wB + ?T) => - apply Z.le_trans with ((2 * Z - 1) * wB + wB); auto with zarith - end. - destruct (spec_to_Z w1);auto with zarith. - match goal with |- ?X <= _ => - replace X with (2 * [|w4|] * wB); auto with zarith - end. - rewrite Z.mul_add_distr_l; rewrite Z.mul_assoc. - destruct (spec_to_Z w5); auto with zarith. - ring. - intros z; replace [-[C1 z]] with (- wwB + [[z]]). - 2: simpl; case wwB; auto with zarith. - intros H5; rewrite spec_w_square_c in H5; - auto. - match goal with |- context [ww_pred_c ?y] => - generalize (spec_ww_pred_c y); case (ww_pred_c y) - end. - intros z1; change [-[C0 z1]] with ([[z1]]). - rewrite ww_add_mult_mult_2. - rewrite spec_ww_add_c. - rewrite spec_ww_pred. - rewrite <- Zmod_unique with (q := 1) (r := -wwB + 2 * [[WW w4 w5]]); - auto with zarith. - intros Hz1; rewrite Zmod_small; auto with zarith. - match type of H5 with -?X + ?Y = ?Z => - assert (V: Y = Z + X); - try (rewrite <- H5; ring) - end. - split. - unfold zn2z_to_Z; rewrite <- Hw1. - unfold ww_to_Z, zn2z_to_Z in H1; rewrite H1. - rewrite <- Hw0. - match goal with |- (?X ^2 + ?Y) * wwB + (?Z * wB + ?T) = ?U => - transitivity ((X * wB) ^ 2 + (Y * wB + Z) * wB + T) - end. - repeat rewrite Zsquare_mult. - rewrite wwB_wBwB; ring. - rewrite H3. - rewrite V. - rewrite Hz1. - unfold ww_to_Z; simpl zn2z_to_Z. - repeat rewrite Zsquare_mult; ring. - rewrite Hz1. - destruct (spec_ww_to_Z w_digits w_to_Z spec_to_Z z);auto with zarith. - assert (V1 := spec_ww_to_Z w_digits w_to_Z spec_to_Z (WW w4 w5)). - assert (0 < [[WW w4 w5]]); auto with zarith. - apply Z.lt_le_trans with (wB/ 2 * wB + 0); auto with zarith. - autorewrite with rm10; apply Z.mul_pos_pos; auto with zarith. - apply Z.mul_lt_mono_pos_r with 2; auto with zarith. - autorewrite with rm10. - rewrite Z.mul_comm; rewrite wB_div_2; auto with zarith. - case (spec_to_Z w5);auto with zarith. - case (spec_to_Z w5);auto with zarith. - simpl. - assert (V2 := spec_to_Z w5);auto with zarith. - assert (V1 := spec_ww_to_Z w_digits w_to_Z spec_to_Z (WW w4 w5)); auto with zarith. - split; auto with zarith. - assert (wwB <= 2 * [[WW w4 w5]]); auto with zarith. - apply Z.le_trans with (2 * ([|w4|] * wB)). - rewrite wwB_wBwB; rewrite Z.pow_2_r. - rewrite Z.mul_assoc; apply Z.mul_le_mono_nonneg_r; auto with zarith. - assert (V2 := spec_to_Z w5);auto with zarith. - rewrite <- wB_div_2; auto with zarith. - simpl ww_to_Z; assert (V2 := spec_to_Z w5);auto with zarith. - assert (V1 := spec_ww_to_Z w_digits w_to_Z spec_to_Z (WW w4 w5)); auto with zarith. - intros z1; change [-[C1 z1]] with (-wwB + [[z1]]). - match goal with |- context[([+[C0 ?z]])] => - change [+[C0 z]] with ([[z]]) - end. - rewrite spec_ww_add; auto with zarith. - rewrite spec_ww_pred; auto with zarith. - rewrite ww_add_mult_mult_2. - rename V1 into VV1. - assert (VV2: 0 < [[WW w4 w5]]); auto with zarith. - apply Z.lt_le_trans with (wB/ 2 * wB + 0); auto with zarith. - autorewrite with rm10; apply Z.mul_pos_pos; auto with zarith. - apply Z.mul_lt_mono_pos_r with 2; auto with zarith. - autorewrite with rm10. - rewrite Z.mul_comm; rewrite wB_div_2; auto with zarith. - assert (VV3 := spec_to_Z w5);auto with zarith. - assert (VV3 := spec_to_Z w5);auto with zarith. - simpl. - assert (VV3 := spec_to_Z w5);auto with zarith. - assert (VV3: wwB <= 2 * [[WW w4 w5]]); auto with zarith. - apply Z.le_trans with (2 * ([|w4|] * wB)). - rewrite wwB_wBwB; rewrite Z.pow_2_r. - rewrite Z.mul_assoc; apply Z.mul_le_mono_nonneg_r; auto with zarith. - case (spec_to_Z w5);auto with zarith. - rewrite <- wB_div_2; auto with zarith. - simpl ww_to_Z; assert (V4 := spec_to_Z w5);auto with zarith. - rewrite <- Zmod_unique with (q := 1) (r := -wwB + 2 * [[WW w4 w5]]); - auto with zarith. - intros Hz1; rewrite Zmod_small; auto with zarith. - match type of H5 with -?X + ?Y = ?Z => - assert (V: Y = Z + X); - try (rewrite <- H5; ring) - end. - match type of Hz1 with -?X + ?Y = -?X + ?Z - 1 => - assert (V1: Y = Z - 1); - [replace (Z - 1) with (X + (-X + Z -1)); - [rewrite <- Hz1 | idtac]; ring - | idtac] - end. - rewrite <- Zmod_unique with (q := 1) (r := -wwB + [[z1]] + [[z]]); - auto with zarith. - unfold zn2z_to_Z; rewrite <- Hw1. - unfold ww_to_Z, zn2z_to_Z in H1; rewrite H1. - rewrite <- Hw0. - split. - match goal with |- (?X ^2 + ?Y) * wwB + (?Z * wB + ?T) = ?U => - transitivity ((X * wB) ^ 2 + (Y * wB + Z) * wB + T) - end. - repeat rewrite Zsquare_mult. - rewrite wwB_wBwB; ring. - rewrite H3. - rewrite V. - rewrite Hz1. - unfold ww_to_Z; simpl zn2z_to_Z. - repeat rewrite Zsquare_mult; ring. - assert (V2 := spec_ww_to_Z w_digits w_to_Z spec_to_Z z);auto with zarith. - assert (V2 := spec_ww_to_Z w_digits w_to_Z spec_to_Z z);auto with zarith. - assert (V3 := spec_ww_to_Z w_digits w_to_Z spec_to_Z z1);auto with zarith. - split; auto with zarith. - rewrite (Z.add_comm (-wwB)); rewrite <- Z.add_assoc. - rewrite H5. - match goal with |- 0 <= ?X + (?Y - ?Z) => - apply Z.le_trans with (X - Z); auto with zarith - end. - 2: generalize (spec_ww_to_Z w_digits w_to_Z spec_to_Z (WW w6 w1)); unfold ww_to_Z; auto with zarith. - rewrite V1. - match goal with |- 0 <= ?X - 1 - ?Y => - assert (Y < X); auto with zarith - end. - apply Z.lt_le_trans with wwB; auto with zarith. - intros (H3, H4). - match goal with |- context [ww_sub_c ?y ?z] => - generalize (spec_ww_sub_c y z); case (ww_sub_c y z) - end. - intros z; change [-[C0 z]] with ([[z]]). - match goal with |- context[([+[C1 ?z]])] => - replace [+[C1 z]] with (wwB + [[z]]) - end. - 2: simpl; case wwB; auto. - intros H5; rewrite spec_w_square_c in H5; - auto. - split. - change ([||WW x y||]) with ([[x]] * wwB + [[y]]). - rewrite <- Hw1. - unfold ww_to_Z, zn2z_to_Z in H1; rewrite H1. - rewrite <- Hw0. - match goal with |- (?X ^2 + ?Y) * wwB + (?Z * wB + ?T) = ?U => - transitivity ((X * wB) ^ 2 + (Y * wB + Z) * wB + T) - end. - repeat rewrite Zsquare_mult. - rewrite wwB_wBwB; ring. - rewrite H3. - rewrite H5. - unfold ww_to_Z; simpl zn2z_to_Z. - rewrite wwB_wBwB. - repeat rewrite Zsquare_mult; ring. - simpl ww_to_Z. - rewrite H5. - simpl ww_to_Z. - rewrite wwB_wBwB; rewrite Z.pow_2_r. - match goal with |- ?X * ?Y + (?Z * ?Y + ?T - ?U) <= _ => - apply Z.le_trans with (X * Y + (Z * Y + T - 0)); - auto with zarith - end. - assert (V := Zsquare_pos [|w5|]); - rewrite Zsquare_mult in V; auto with zarith. - autorewrite with rm10. - match goal with |- _ <= 2 * (?U * ?V + ?W) => - apply Z.le_trans with (2 * U * V + 0); - auto with zarith - end. - match goal with |- ?X * ?Y + (?Z * ?Y + ?T) <= _ => - replace (X * Y + (Z * Y + T)) with ((X + Z) * Y + T); - try ring - end. - apply Z.lt_le_incl; apply beta_lex_inv; auto with zarith. - destruct (spec_to_Z w1);auto with zarith. - destruct (spec_to_Z w5);auto with zarith. - rewrite Z.mul_add_distr_l; auto with zarith. - rewrite Z.mul_assoc; auto with zarith. - intros z; replace [-[C1 z]] with (- wwB + [[z]]). - 2: simpl; case wwB; auto with zarith. - intros H5; rewrite spec_w_square_c in H5; - auto. - match goal with |- context[([+[C0 ?z]])] => - change [+[C0 z]] with ([[z]]) - end. - match type of H5 with -?X + ?Y = ?Z => - assert (V: Y = Z + X); - try (rewrite <- H5; ring) - end. - change ([||WW x y||]) with ([[x]] * wwB + [[y]]). - simpl ww_to_Z. - rewrite <- Hw1. - simpl ww_to_Z in H1; rewrite H1. - rewrite <- Hw0. - split. - match goal with |- (?X ^2 + ?Y) * wwB + (?Z * wB + ?T) = ?U => - transitivity ((X * wB) ^ 2 + (Y * wB + Z) * wB + T) - end. - repeat rewrite Zsquare_mult. - rewrite wwB_wBwB; ring. - rewrite H3. - rewrite V. - simpl ww_to_Z. - rewrite wwB_wBwB. - repeat rewrite Zsquare_mult; ring. - rewrite V. - simpl ww_to_Z. - rewrite wwB_wBwB; rewrite Z.pow_2_r. - match goal with |- (?Z * ?Y + ?T - ?U) + ?X * ?Y <= _ => - apply Z.le_trans with ((Z * Y + T - 0) + X * Y); - auto with zarith - end. - assert (V1 := Zsquare_pos [|w5|]); - rewrite Zsquare_mult in V1; auto with zarith. - autorewrite with rm10. - match goal with |- _ <= 2 * (?U * ?V + ?W) => - apply Z.le_trans with (2 * U * V + 0); - auto with zarith - end. - match goal with |- (?Z * ?Y + ?T) + ?X * ?Y <= _ => - replace ((Z * Y + T) + X * Y) with ((X + Z) * Y + T); - try ring - end. - apply Z.lt_le_incl; apply beta_lex_inv; auto with zarith. - destruct (spec_to_Z w1);auto with zarith. - destruct (spec_to_Z w5);auto with zarith. - rewrite Z.mul_add_distr_l; auto with zarith. - rewrite Z.mul_assoc; auto with zarith. - Z.le_elim H2. - intros c1 (H3, H4). - match type of H3 with ?X = ?Y => absurd (X < Y) end. - apply Z.le_ngt; rewrite <- H3; auto with zarith. - rewrite Z.mul_add_distr_r. - apply Z.lt_le_trans with ((2 * [|w4|]) * wB + 0); - auto with zarith. - apply beta_lex_inv; auto with zarith. - destruct (spec_to_Z w0);auto with zarith. - assert (V1 := spec_to_Z w5);auto with zarith. - rewrite (Z.mul_comm wB); auto with zarith. - assert (0 <= [|w5|] * (2 * [|w4|])); auto with zarith. - intros c1 (H3, H4); rewrite H2 in H3. - match type of H3 with ?X + ?Y = (?Z + ?T) * ?U + ?V => - assert (VV: (Y = (T * U) + V)); - [replace Y with ((X + Y) - X); - [rewrite H3; ring | ring] | idtac] - end. - assert (V1 := spec_to_Z w0);auto with zarith. - assert (V2 := spec_to_Z w5);auto with zarith. - case V2; intros V3 _. - Z.le_elim V3; auto with zarith. - match type of VV with ?X = ?Y => absurd (X < Y) end. - apply Z.le_ngt; rewrite <- VV; auto with zarith. - apply Z.lt_le_trans with wB; auto with zarith. - match goal with |- _ <= ?X + _ => - apply Z.le_trans with X; auto with zarith - end. - match goal with |- _ <= _ * ?X => - apply Z.le_trans with (1 * X); auto with zarith - end. - autorewrite with rm10. - rewrite <- wB_div_2; apply Z.mul_le_mono_nonneg_l; auto with zarith. - rewrite <- V3 in VV; generalize VV; autorewrite with rm10; - clear VV; intros VV. - rewrite spec_ww_add_c; auto with zarith. - rewrite ww_add_mult_mult_2_plus_1. - match goal with |- context[?X mod wwB] => - rewrite <- Zmod_unique with (q := 1) (r := -wwB + X) - end; auto with zarith. - simpl ww_to_Z. - rewrite spec_w_Bm1; auto with zarith. - split. - change ([||WW x y||]) with ([[x]] * wwB + [[y]]). - rewrite <- Hw1. - simpl ww_to_Z in H1; rewrite H1. - rewrite <- Hw0. - match goal with |- (?X ^2 + ?Y) * wwB + (?Z * wB + ?T) = ?U => - transitivity ((X * wB) ^ 2 + (Y * wB + Z) * wB + T) - end. - repeat rewrite Zsquare_mult. - rewrite wwB_wBwB; ring. - rewrite H2. - rewrite wwB_wBwB. - repeat rewrite Zsquare_mult; ring. - assert (V4 := spec_ww_to_Z w_digits w_to_Z spec_to_Z y);auto with zarith. - assert (V4 := spec_ww_to_Z w_digits w_to_Z spec_to_Z y);auto with zarith. - simpl ww_to_Z; unfold ww_to_Z. - rewrite spec_w_Bm1; auto with zarith. - split. - rewrite wwB_wBwB; rewrite Z.pow_2_r. - match goal with |- _ <= -?X + (2 * (?Z * ?T + ?U) + ?V) => - assert (X <= 2 * Z * T); auto with zarith - end. - apply Z.mul_le_mono_nonneg_r; auto with zarith. - rewrite <- wB_div_2; apply Z.mul_le_mono_nonneg_l; auto with zarith. - rewrite Z.mul_add_distr_l; auto with zarith. - rewrite Z.mul_assoc; auto with zarith. - match goal with |- _ + ?X < _ => - replace X with ((2 * (([|w4|]) + 1) * wB) - 1); try ring - end. - assert (2 * ([|w4|] + 1) * wB <= 2 * wwB); auto with zarith. - rewrite <- Z.mul_assoc; apply Z.mul_le_mono_nonneg_l; auto with zarith. - rewrite wwB_wBwB; rewrite Z.pow_2_r. - apply Z.mul_le_mono_nonneg_r; auto with zarith. - case (spec_to_Z w4);auto with zarith. -Qed. - - Lemma spec_ww_is_zero: forall x, - if ww_is_zero x then [[x]] = 0 else 0 < [[x]]. - intro x; unfold ww_is_zero. - rewrite spec_ww_compare. case Z.compare_spec; - auto with zarith. - simpl ww_to_Z. - assert (V4 := spec_ww_to_Z w_digits w_to_Z spec_to_Z x);auto with zarith. - Qed. - - Lemma wwB_4_2: 2 * (wwB / 4) = wwB/ 2. - pattern wwB at 1; rewrite wwB_wBwB; rewrite Z.pow_2_r. - rewrite <- wB_div_2. - match goal with |- context[(2 * ?X) * (2 * ?Z)] => - replace ((2 * X) * (2 * Z)) with ((X * Z) * 4); try ring - end. - rewrite Z_div_mult; auto with zarith. - rewrite Z.mul_assoc; rewrite wB_div_2. - rewrite wwB_div_2; ring. - Qed. - - - Lemma spec_ww_head1 - : forall x : zn2z w, - (ww_is_even (ww_head1 x) = true) /\ - (0 < [[x]] -> wwB / 4 <= 2 ^ [[ww_head1 x]] * [[x]] < wwB). - assert (U := wB_pos w_digits). - intros x; unfold ww_head1. - generalize (spec_ww_is_even (ww_head0 x)); case_eq (ww_is_even (ww_head0 x)). - intros HH H1; rewrite HH; split; auto. - intros H2. - generalize (spec_ww_head0 x H2); case (ww_head0 x); autorewrite with rm10. - intros (H3, H4); split; auto with zarith. - apply Z.le_trans with (2 := H3). - apply Zdiv_le_compat_l; auto with zarith. - intros xh xl (H3, H4); split; auto with zarith. - apply Z.le_trans with (2 := H3). - apply Zdiv_le_compat_l; auto with zarith. - intros H1. - case (spec_to_w_Z (ww_head0 x)); intros Hv1 Hv2. - assert (Hp0: 0 < [[ww_head0 x]]). - generalize (spec_ww_is_even (ww_head0 x)); rewrite H1. - generalize Hv1; case [[ww_head0 x]]. - rewrite Zmod_small; auto with zarith. - intros; assert (0 < Zpos p); auto with zarith. - red; simpl; auto. - intros p H2; case H2; auto. - assert (Hp: [[ww_pred (ww_head0 x)]] = [[ww_head0 x]] - 1). - rewrite spec_ww_pred. - rewrite Zmod_small; auto with zarith. - intros H2; split. - generalize (spec_ww_is_even (ww_pred (ww_head0 x))); - case ww_is_even; auto. - rewrite Hp. - rewrite Zminus_mod; auto with zarith. - rewrite H2; repeat rewrite Zmod_small; auto with zarith. - intros H3; rewrite Hp. - case (spec_ww_head0 x); auto; intros Hv3 Hv4. - assert (Hu: forall u, 0 < u -> 2 * 2 ^ (u - 1) = 2 ^u). - intros u Hu. - pattern 2 at 1; rewrite <- Z.pow_1_r. - rewrite <- Zpower_exp; auto with zarith. - ring_simplify (1 + (u - 1)); auto with zarith. - split; auto with zarith. - apply Z.mul_le_mono_pos_r with 2; auto with zarith. - repeat rewrite (fun x => Z.mul_comm x 2). - rewrite wwB_4_2. - rewrite Z.mul_assoc; rewrite Hu; auto with zarith. - apply Z.le_lt_trans with (2 * 2 ^ ([[ww_head0 x]] - 1) * [[x]]); auto with zarith; - rewrite Hu; auto with zarith. - apply Z.mul_le_mono_nonneg_r; auto with zarith. - apply Zpower_le_monotone; auto with zarith. - Qed. - - Theorem wwB_4_wB_4: wwB / 4 = wB / 4 * wB. - Proof. - symmetry; apply Zdiv_unique with 0; auto with zarith. - rewrite Z.mul_assoc; rewrite wB_div_4; auto with zarith. - rewrite wwB_wBwB; ring. - Qed. - - Lemma spec_ww_sqrt : forall x, - [[ww_sqrt x]] ^ 2 <= [[x]] < ([[ww_sqrt x]] + 1) ^ 2. - assert (U := wB_pos w_digits). - intro x; unfold ww_sqrt. - generalize (spec_ww_is_zero x); case (ww_is_zero x). - simpl ww_to_Z; simpl Z.pow; unfold Z.pow_pos; simpl; - auto with zarith. - intros H1. - rewrite spec_ww_compare. case Z.compare_spec; - simpl ww_to_Z; autorewrite with rm10. - generalize H1; case x. - intros HH; contradict HH; simpl ww_to_Z; auto with zarith. - intros w0 w1; simpl ww_to_Z; autorewrite with w_rewrite rm10. - intros H2; case (spec_ww_head1 (WW w0 w1)); intros H3 H4 H5. - generalize (H4 H2); clear H4; rewrite H5; clear H5; autorewrite with rm10. - intros (H4, H5). - assert (V: wB/4 <= [|w0|]). - apply beta_lex with 0 [|w1|] wB; auto with zarith; autorewrite with rm10. - rewrite <- wwB_4_wB_4; auto. - generalize (@spec_w_sqrt2 w0 w1 V);auto with zarith. - case (w_sqrt2 w0 w1); intros w2 c. - simpl ww_to_Z; simpl @fst. - case c; unfold interp_carry; autorewrite with rm10. - intros w3 (H6, H7); rewrite H6. - assert (V1 := spec_to_Z w3);auto with zarith. - split; auto with zarith. - apply Z.le_lt_trans with ([|w2|] ^2 + 2 * [|w2|]); auto with zarith. - match goal with |- ?X < ?Z => - replace Z with (X + 1); auto with zarith - end. - repeat rewrite Zsquare_mult; ring. - intros w3 (H6, H7); rewrite H6. - assert (V1 := spec_to_Z w3);auto with zarith. - split; auto with zarith. - apply Z.le_lt_trans with ([|w2|] ^2 + 2 * [|w2|]); auto with zarith. - match goal with |- ?X < ?Z => - replace Z with (X + 1); auto with zarith - end. - repeat rewrite Zsquare_mult; ring. - intros HH; case (spec_to_w_Z (ww_head1 x)); auto with zarith. - intros Hv1. - case (spec_ww_head1 x); intros Hp1 Hp2. - generalize (Hp2 H1); clear Hp2; intros Hp2. - assert (Hv2: [[ww_head1 x]] <= Zpos (xO w_digits)). - case (Z.le_gt_cases (Zpos (xO w_digits)) [[ww_head1 x]]); auto with zarith; intros HH1. - case Hp2; intros _ HH2; contradict HH2. - apply Z.le_ngt; unfold base. - apply Z.le_trans with (2 ^ [[ww_head1 x]]). - apply Zpower_le_monotone; auto with zarith. - pattern (2 ^ [[ww_head1 x]]) at 1; - rewrite <- (Z.mul_1_r (2 ^ [[ww_head1 x]])). - apply Z.mul_le_mono_nonneg_l; auto with zarith. - generalize (spec_ww_add_mul_div x W0 (ww_head1 x) Hv2); - case ww_add_mul_div. - simpl ww_to_Z; autorewrite with w_rewrite rm10. - rewrite Zmod_small; auto with zarith. - intros H2. symmetry in H2. rewrite Z.mul_eq_0 in H2. destruct H2 as [H2|H2]. - rewrite H2; unfold Z.pow, Z.pow_pos; simpl; auto with zarith. - match type of H2 with ?X = ?Y => - absurd (Y < X); try (rewrite H2; auto with zarith; fail) - end. - apply Z.pow_pos_nonneg; auto with zarith. - split; auto with zarith. - case Hp2; intros _ tmp; apply Z.le_lt_trans with (2 := tmp); - clear tmp. - rewrite Z.mul_comm; apply Z.mul_le_mono_nonneg_r; auto with zarith. - assert (Hv0: [[ww_head1 x]] = 2 * ([[ww_head1 x]]/2)). - pattern [[ww_head1 x]] at 1; rewrite (Z_div_mod_eq [[ww_head1 x]] 2); - auto with zarith. - generalize (spec_ww_is_even (ww_head1 x)); rewrite Hp1; - intros tmp; rewrite tmp; rewrite Z.add_0_r; auto. - intros w0 w1; autorewrite with w_rewrite rm10. - rewrite Zmod_small; auto with zarith. - 2: rewrite Z.mul_comm; auto with zarith. - intros H2. - assert (V: wB/4 <= [|w0|]). - apply beta_lex with 0 [|w1|] wB; auto with zarith; autorewrite with rm10. - simpl ww_to_Z in H2; rewrite H2. - rewrite <- wwB_4_wB_4; auto with zarith. - rewrite Z.mul_comm; auto with zarith. - assert (V1 := spec_to_Z w1);auto with zarith. - generalize (@spec_w_sqrt2 w0 w1 V);auto with zarith. - case (w_sqrt2 w0 w1); intros w2 c. - case (spec_to_Z w2); intros HH1 HH2. - simpl ww_to_Z; simpl @fst. - assert (Hv3: [[ww_pred ww_zdigits]] - = Zpos (xO w_digits) - 1). - rewrite spec_ww_pred; rewrite spec_ww_zdigits. - rewrite Zmod_small; auto with zarith. - split; auto with zarith. - apply Z.lt_le_trans with (Zpos (xO w_digits)); auto with zarith. - unfold base; apply Zpower2_le_lin; auto with zarith. - assert (Hv4: [[ww_head1 x]]/2 < wB). - apply Z.le_lt_trans with (Zpos w_digits). - apply Z.mul_le_mono_pos_r with 2; auto with zarith. - repeat rewrite (fun x => Z.mul_comm x 2). - rewrite <- Hv0; rewrite <- Pos2Z.inj_xO; auto. - unfold base; apply Zpower2_lt_lin; auto with zarith. - assert (Hv5: [[(ww_add_mul_div (ww_pred ww_zdigits) W0 (ww_head1 x))]] - = [[ww_head1 x]]/2). - rewrite spec_ww_add_mul_div. - simpl ww_to_Z; autorewrite with rm10. - rewrite Hv3. - ring_simplify (Zpos (xO w_digits) - (Zpos (xO w_digits) - 1)). - rewrite Z.pow_1_r. - rewrite Zmod_small; auto with zarith. - split; auto with zarith. - apply Z.lt_le_trans with (1 := Hv4); auto with zarith. - unfold base; apply Zpower_le_monotone; auto with zarith. - split; unfold ww_digits; try rewrite Pos2Z.inj_xO; auto with zarith. - rewrite Hv3; auto with zarith. - assert (Hv6: [|low(ww_add_mul_div (ww_pred ww_zdigits) W0 (ww_head1 x))|] - = [[ww_head1 x]]/2). - rewrite spec_low. - rewrite Hv5; rewrite Zmod_small; auto with zarith. - rewrite spec_w_add_mul_div; auto with zarith. - rewrite spec_w_sub; auto with zarith. - rewrite spec_w_0. - simpl ww_to_Z; autorewrite with rm10. - rewrite Hv6; rewrite spec_w_zdigits. - rewrite (fun x y => Zmod_small (x - y)). - ring_simplify (Zpos w_digits - (Zpos w_digits - [[ww_head1 x]] / 2)). - rewrite Zmod_small. - simpl ww_to_Z in H2; rewrite H2; auto with zarith. - intros (H4, H5); split. - apply Z.mul_le_mono_pos_r with (2 ^ [[ww_head1 x]]); auto with zarith. - rewrite H4. - apply Z.le_trans with ([|w2|] ^ 2); auto with zarith. - rewrite Z.mul_comm. - pattern [[ww_head1 x]] at 1; - rewrite Hv0; auto with zarith. - rewrite (Z.mul_comm 2); rewrite Z.pow_mul_r; - auto with zarith. - assert (tmp: forall p q, p ^ 2 * q ^ 2 = (p * q) ^2); - try (intros; repeat rewrite Zsquare_mult; ring); - rewrite tmp; clear tmp. - apply Zpower_le_monotone3; auto with zarith. - split; auto with zarith. - pattern [|w2|] at 2; - rewrite (Z_div_mod_eq [|w2|] (2 ^ ([[ww_head1 x]] / 2))); - auto with zarith. - match goal with |- ?X <= ?X + ?Y => - assert (0 <= Y); auto with zarith - end. - case (Z_mod_lt [|w2|] (2 ^ ([[ww_head1 x]] / 2))); auto with zarith. - case c; unfold interp_carry; autorewrite with rm10; - intros w3; assert (V3 := spec_to_Z w3);auto with zarith. - apply Z.mul_lt_mono_pos_r with (2 ^ [[ww_head1 x]]); auto with zarith. - rewrite H4. - apply Z.le_lt_trans with ([|w2|] ^ 2 + 2 * [|w2|]); auto with zarith. - apply Z.lt_le_trans with (([|w2|] + 1) ^ 2); auto with zarith. - match goal with |- ?X < ?Y => - replace Y with (X + 1); auto with zarith - end. - repeat rewrite (Zsquare_mult); ring. - rewrite Z.mul_comm. - pattern [[ww_head1 x]] at 1; rewrite Hv0. - rewrite (Z.mul_comm 2); rewrite Z.pow_mul_r; - auto with zarith. - assert (tmp: forall p q, p ^ 2 * q ^ 2 = (p * q) ^2); - try (intros; repeat rewrite Zsquare_mult; ring); - rewrite tmp; clear tmp. - apply Zpower_le_monotone3; auto with zarith. - split; auto with zarith. - pattern [|w2|] at 1; rewrite (Z_div_mod_eq [|w2|] (2 ^ ([[ww_head1 x]]/2))); - auto with zarith. - rewrite <- Z.add_assoc; rewrite Z.mul_add_distr_l. - autorewrite with rm10; apply Z.add_le_mono_l; auto with zarith. - case (Z_mod_lt [|w2|] (2 ^ ([[ww_head1 x]]/2))); auto with zarith. - split; auto with zarith. - apply Z.le_lt_trans with ([|w2|]); auto with zarith. - apply Zdiv_le_upper_bound; auto with zarith. - pattern [|w2|] at 1; replace [|w2|] with ([|w2|] * 2 ^0); - auto with zarith. - apply Z.mul_le_mono_nonneg_l; auto with zarith. - apply Zpower_le_monotone; auto with zarith. - rewrite Z.pow_0_r; autorewrite with rm10; auto. - split; auto with zarith. - rewrite Hv0 in Hv2; rewrite (Pos2Z.inj_xO w_digits) in Hv2; auto with zarith. - apply Z.le_lt_trans with (Zpos w_digits); auto with zarith. - unfold base; apply Zpower2_lt_lin; auto with zarith. - rewrite spec_w_sub; auto with zarith. - rewrite Hv6; rewrite spec_w_zdigits; auto with zarith. - assert (Hv7: 0 < [[ww_head1 x]]/2); auto with zarith. - rewrite Zmod_small; auto with zarith. - split; auto with zarith. - assert ([[ww_head1 x]]/2 <= Zpos w_digits); auto with zarith. - apply Z.mul_le_mono_pos_r with 2; auto with zarith. - repeat rewrite (fun x => Z.mul_comm x 2). - rewrite <- Hv0; rewrite <- Pos2Z.inj_xO; auto with zarith. - apply Z.le_lt_trans with (Zpos w_digits); auto with zarith. - unfold base; apply Zpower2_lt_lin; auto with zarith. - Qed. - -End DoubleSqrt. diff --git a/theories/Numbers/Cyclic/DoubleCyclic/DoubleSub.v b/theories/Numbers/Cyclic/DoubleCyclic/DoubleSub.v deleted file mode 100644 index a2df260020..0000000000 --- a/theories/Numbers/Cyclic/DoubleCyclic/DoubleSub.v +++ /dev/null @@ -1,356 +0,0 @@ - -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) -(* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) -(************************************************************************) - -Set Implicit Arguments. - -Require Import ZArith. -Require Import BigNumPrelude. -Require Import DoubleType. -Require Import DoubleBase. - -Local Open Scope Z_scope. - -Section DoubleSub. - Variable w : Type. - Variable w_0 : w. - Variable w_Bm1 : w. - Variable w_WW : w -> w -> zn2z w. - Variable ww_Bm1 : zn2z w. - Variable w_opp_c : w -> carry w. - Variable w_opp_carry : w -> w. - Variable w_pred_c : w -> carry w. - Variable w_sub_c : w -> w -> carry w. - Variable w_sub_carry_c : w -> w -> carry w. - Variable w_opp : w -> w. - Variable w_pred : w -> w. - Variable w_sub : w -> w -> w. - Variable w_sub_carry : w -> w -> w. - - (* ** Opposites ** *) - Definition ww_opp_c x := - match x with - | W0 => C0 W0 - | WW xh xl => - match w_opp_c xl with - | C0 _ => - match w_opp_c xh with - | C0 h => C0 W0 - | C1 h => C1 (WW h w_0) - end - | C1 l => C1 (WW (w_opp_carry xh) l) - end - end. - - Definition ww_opp x := - match x with - | W0 => W0 - | WW xh xl => - match w_opp_c xl with - | C0 _ => WW (w_opp xh) w_0 - | C1 l => WW (w_opp_carry xh) l - end - end. - - Definition ww_opp_carry x := - match x with - | W0 => ww_Bm1 - | WW xh xl => w_WW (w_opp_carry xh) (w_opp_carry xl) - end. - - Definition ww_pred_c x := - match x with - | W0 => C1 ww_Bm1 - | WW xh xl => - match w_pred_c xl with - | C0 l => C0 (w_WW xh l) - | C1 _ => - match w_pred_c xh with - | C0 h => C0 (WW h w_Bm1) - | C1 _ => C1 ww_Bm1 - end - end - end. - - Definition ww_pred x := - match x with - | W0 => ww_Bm1 - | WW xh xl => - match w_pred_c xl with - | C0 l => w_WW xh l - | C1 l => WW (w_pred xh) w_Bm1 - end - end. - - Definition ww_sub_c x y := - match y, x with - | W0, _ => C0 x - | WW yh yl, W0 => ww_opp_c (WW yh yl) - | WW yh yl, WW xh xl => - match w_sub_c xl yl with - | C0 l => - match w_sub_c xh yh with - | C0 h => C0 (w_WW h l) - | C1 h => C1 (WW h l) - end - | C1 l => - match w_sub_carry_c xh yh with - | C0 h => C0 (WW h l) - | C1 h => C1 (WW h l) - end - end - end. - - Definition ww_sub x y := - match y, x with - | W0, _ => x - | WW yh yl, W0 => ww_opp (WW yh yl) - | WW yh yl, WW xh xl => - match w_sub_c xl yl with - | C0 l => w_WW (w_sub xh yh) l - | C1 l => WW (w_sub_carry xh yh) l - end - end. - - Definition ww_sub_carry_c x y := - match y, x with - | W0, W0 => C1 ww_Bm1 - | W0, WW xh xl => ww_pred_c (WW xh xl) - | WW yh yl, W0 => C1 (ww_opp_carry (WW yh yl)) - | WW yh yl, WW xh xl => - match w_sub_carry_c xl yl with - | C0 l => - match w_sub_c xh yh with - | C0 h => C0 (w_WW h l) - | C1 h => C1 (WW h l) - end - | C1 l => - match w_sub_carry_c xh yh with - | C0 h => C0 (w_WW h l) - | C1 h => C1 (w_WW h l) - end - end - end. - - Definition ww_sub_carry x y := - match y, x with - | W0, W0 => ww_Bm1 - | W0, WW xh xl => ww_pred (WW xh xl) - | WW yh yl, W0 => ww_opp_carry (WW yh yl) - | WW yh yl, WW xh xl => - match w_sub_carry_c xl yl with - | C0 l => w_WW (w_sub xh yh) l - | C1 l => w_WW (w_sub_carry xh yh) l - end - end. - - (*Section DoubleProof.*) - Variable w_digits : positive. - Variable w_to_Z : w -> Z. - - - Notation wB := (base w_digits). - Notation wwB := (base (ww_digits w_digits)). - Notation "[| x |]" := (w_to_Z x) (at level 0, x at level 99). - Notation "[+| c |]" := - (interp_carry 1 wB w_to_Z c) (at level 0, c at level 99). - Notation "[-| c |]" := - (interp_carry (-1) wB w_to_Z c) (at level 0, c at level 99). - - Notation "[[ x ]]" := (ww_to_Z w_digits w_to_Z x)(at level 0, x at level 99). - Notation "[+[ c ]]" := - (interp_carry 1 wwB (ww_to_Z w_digits w_to_Z) c) - (at level 0, c at level 99). - Notation "[-[ c ]]" := - (interp_carry (-1) wwB (ww_to_Z w_digits w_to_Z) c) - (at level 0, c at level 99). - - Variable spec_w_0 : [|w_0|] = 0. - Variable spec_w_Bm1 : [|w_Bm1|] = wB - 1. - Variable spec_ww_Bm1 : [[ww_Bm1]] = wwB - 1. - Variable spec_to_Z : forall x, 0 <= [|x|] < wB. - Variable spec_w_WW : forall h l, [[w_WW h l]] = [|h|] * wB + [|l|]. - - Variable spec_opp_c : forall x, [-|w_opp_c x|] = -[|x|]. - Variable spec_opp : forall x, [|w_opp x|] = (-[|x|]) mod wB. - Variable spec_opp_carry : forall x, [|w_opp_carry x|] = wB - [|x|] - 1. - - Variable spec_pred_c : forall x, [-|w_pred_c x|] = [|x|] - 1. - Variable spec_sub_c : forall x y, [-|w_sub_c x y|] = [|x|] - [|y|]. - Variable spec_sub_carry_c : - forall x y, [-|w_sub_carry_c x y|] = [|x|] - [|y|] - 1. - - Variable spec_pred : forall x, [|w_pred x|] = ([|x|] - 1) mod wB. - Variable spec_sub : forall x y, [|w_sub x y|] = ([|x|] - [|y|]) mod wB. - Variable spec_sub_carry : - forall x y, [|w_sub_carry x y|] = ([|x|] - [|y|] - 1) mod wB. - - - Lemma spec_ww_opp_c : forall x, [-[ww_opp_c x]] = -[[x]]. - Proof. - destruct x as [ |xh xl];simpl. reflexivity. - rewrite Z.opp_add_distr;generalize (spec_opp_c xl);destruct (w_opp_c xl) - as [l|l];intros H;unfold interp_carry in H;rewrite <- H; - rewrite <- Z.mul_opp_l. - assert ([|l|] = 0). - assert (H1:= spec_to_Z l);assert (H2 := spec_to_Z xl);omega. - rewrite H0;generalize (spec_opp_c xh);destruct (w_opp_c xh) - as [h|h];intros H1;unfold interp_carry in *;rewrite <- H1. - assert ([|h|] = 0). - assert (H3:= spec_to_Z h);assert (H2 := spec_to_Z xh);omega. - rewrite H2;reflexivity. - simpl ww_to_Z;rewrite wwB_wBwB;rewrite spec_w_0;ring. - unfold interp_carry;simpl ww_to_Z;rewrite wwB_wBwB;rewrite spec_opp_carry; - ring. - Qed. - - Lemma spec_ww_opp : forall x, [[ww_opp x]] = (-[[x]]) mod wwB. - Proof. - destruct x as [ |xh xl];simpl. reflexivity. - rewrite Z.opp_add_distr, <- Z.mul_opp_l. - generalize (spec_opp_c xl);destruct (w_opp_c xl) - as [l|l];intros H;unfold interp_carry in H;rewrite <- H;simpl ww_to_Z. - rewrite spec_w_0;rewrite Z.add_0_r;rewrite wwB_wBwB. - assert ([|l|] = 0). - assert (H1:= spec_to_Z l);assert (H2 := spec_to_Z xl);omega. - rewrite H0;rewrite Z.add_0_r; rewrite Z.pow_2_r; - rewrite Zmult_mod_distr_r;try apply lt_0_wB. - rewrite spec_opp;trivial. - apply Zmod_unique with (q:= -1). - exact (spec_ww_to_Z w_digits w_to_Z spec_to_Z (WW (w_opp_carry xh) l)). - rewrite spec_opp_carry;rewrite wwB_wBwB;ring. - Qed. - - Lemma spec_ww_opp_carry : forall x, [[ww_opp_carry x]] = wwB - [[x]] - 1. - Proof. - destruct x as [ |xh xl];simpl. rewrite spec_ww_Bm1;ring. - rewrite spec_w_WW;simpl;repeat rewrite spec_opp_carry;rewrite wwB_wBwB;ring. - Qed. - - Lemma spec_ww_pred_c : forall x, [-[ww_pred_c x]] = [[x]] - 1. - Proof. - destruct x as [ |xh xl];unfold ww_pred_c. - unfold interp_carry;rewrite spec_ww_Bm1;simpl ww_to_Z;ring. - simpl ww_to_Z;replace (([|xh|]*wB+[|xl|])-1) with ([|xh|]*wB+([|xl|]-1)). - 2:ring. generalize (spec_pred_c xl);destruct (w_pred_c xl) as [l|l]; - intros H;unfold interp_carry in H;rewrite <- H. simpl;apply spec_w_WW. - rewrite Z.add_assoc;rewrite <- Z.mul_add_distr_r. - assert ([|l|] = wB - 1). - assert (H1:= spec_to_Z l);assert (H2 := spec_to_Z xl);omega. - rewrite H0;change ([|xh|] + -1) with ([|xh|] - 1). - generalize (spec_pred_c xh);destruct (w_pred_c xh) as [h|h]; - intros H1;unfold interp_carry in H1;rewrite <- H1. - simpl;rewrite spec_w_Bm1;ring. - assert ([|h|] = wB - 1). - assert (H3:= spec_to_Z h);assert (H2 := spec_to_Z xh);omega. - rewrite H2;unfold interp_carry;rewrite spec_ww_Bm1;rewrite wwB_wBwB;ring. - Qed. - - Lemma spec_ww_sub_c : forall x y, [-[ww_sub_c x y]] = [[x]] - [[y]]. - Proof. - destruct y as [ |yh yl];simpl. ring. - destruct x as [ |xh xl];simpl. exact (spec_ww_opp_c (WW yh yl)). - replace ([|xh|] * wB + [|xl|] - ([|yh|] * wB + [|yl|])) - with (([|xh|]-[|yh|])*wB + ([|xl|]-[|yl|])). 2:ring. - generalize (spec_sub_c xl yl);destruct (w_sub_c xl yl) as [l|l];intros H; - unfold interp_carry in H;rewrite <- H. - generalize (spec_sub_c xh yh);destruct (w_sub_c xh yh) as [h|h];intros H1; - unfold interp_carry in H1;rewrite <- H1;unfold interp_carry; - try rewrite spec_w_WW;simpl ww_to_Z;try rewrite wwB_wBwB;ring. - rewrite Z.add_assoc;rewrite <- Z.mul_add_distr_r. - change ([|xh|] - [|yh|] + -1) with ([|xh|] - [|yh|] - 1). - generalize (spec_sub_carry_c xh yh);destruct (w_sub_carry_c xh yh) as [h|h]; - intros H1;unfold interp_carry in *;rewrite <- H1;simpl ww_to_Z; - try rewrite wwB_wBwB;ring. - Qed. - - Lemma spec_ww_sub_carry_c : - forall x y, [-[ww_sub_carry_c x y]] = [[x]] - [[y]] - 1. - Proof. - destruct y as [ |yh yl];simpl. - unfold Z.sub;simpl;rewrite Z.add_0_r;exact (spec_ww_pred_c x). - destruct x as [ |xh xl]. - unfold interp_carry;rewrite spec_w_WW;simpl ww_to_Z;rewrite wwB_wBwB; - repeat rewrite spec_opp_carry;ring. - simpl ww_to_Z. - replace ([|xh|] * wB + [|xl|] - ([|yh|] * wB + [|yl|]) - 1) - with (([|xh|]-[|yh|])*wB + ([|xl|]-[|yl|]-1)). 2:ring. - generalize (spec_sub_carry_c xl yl);destruct (w_sub_carry_c xl yl) - as [l|l];intros H;unfold interp_carry in H;rewrite <- H. - generalize (spec_sub_c xh yh);destruct (w_sub_c xh yh) as [h|h];intros H1; - unfold interp_carry in H1;rewrite <- H1;unfold interp_carry; - try rewrite spec_w_WW;simpl ww_to_Z;try rewrite wwB_wBwB;ring. - rewrite Z.add_assoc;rewrite <- Z.mul_add_distr_r. - change ([|xh|] - [|yh|] + -1) with ([|xh|] - [|yh|] - 1). - generalize (spec_sub_carry_c xh yh);destruct (w_sub_carry_c xh yh) as [h|h]; - intros H1;unfold interp_carry in *;rewrite <- H1;try rewrite spec_w_WW; - simpl ww_to_Z; try rewrite wwB_wBwB;ring. - Qed. - - Lemma spec_ww_pred : forall x, [[ww_pred x]] = ([[x]] - 1) mod wwB. - Proof. - destruct x as [ |xh xl];simpl. - apply Zmod_unique with (-1). apply spec_ww_to_Z;trivial. - rewrite spec_ww_Bm1;ring. - replace ([|xh|]*wB + [|xl|] - 1) with ([|xh|]*wB + ([|xl|] - 1)). 2:ring. - generalize (spec_pred_c xl);destruct (w_pred_c xl) as [l|l];intro H; - unfold interp_carry in H;rewrite <- H;simpl ww_to_Z. - rewrite Zmod_small. apply spec_w_WW. - exact (spec_ww_to_Z w_digits w_to_Z spec_to_Z (WW xh l)). - rewrite Z.add_assoc;rewrite <- Z.mul_add_distr_r. - change ([|xh|] + -1) with ([|xh|] - 1). - assert ([|l|] = wB - 1). - assert (H1:= spec_to_Z l);assert (H2:= spec_to_Z xl);omega. - rewrite (mod_wwB w_digits w_to_Z);trivial. - rewrite spec_pred;rewrite spec_w_Bm1;rewrite <- H0;trivial. - Qed. - - Lemma spec_ww_sub : forall x y, [[ww_sub x y]] = ([[x]] - [[y]]) mod wwB. - Proof. - destruct y as [ |yh yl];simpl. - ring_simplify ([[x]] - 0);rewrite Zmod_small;trivial. apply spec_ww_to_Z;trivial. - destruct x as [ |xh xl];simpl. exact (spec_ww_opp (WW yh yl)). - replace ([|xh|] * wB + [|xl|] - ([|yh|] * wB + [|yl|])) - with (([|xh|] - [|yh|]) * wB + ([|xl|] - [|yl|])). 2:ring. - generalize (spec_sub_c xl yl);destruct (w_sub_c xl yl)as[l|l];intros H; - unfold interp_carry in H;rewrite <- H. - rewrite spec_w_WW;rewrite (mod_wwB w_digits w_to_Z spec_to_Z). - rewrite spec_sub;trivial. - simpl ww_to_Z;rewrite Z.add_assoc;rewrite <- Z.mul_add_distr_r. - rewrite (mod_wwB w_digits w_to_Z spec_to_Z);rewrite spec_sub_carry;trivial. - Qed. - - Lemma spec_ww_sub_carry : - forall x y, [[ww_sub_carry x y]] = ([[x]] - [[y]] - 1) mod wwB. - Proof. - destruct y as [ |yh yl];simpl. - ring_simplify ([[x]] - 0);exact (spec_ww_pred x). - destruct x as [ |xh xl];simpl. - apply Zmod_unique with (-1). - apply spec_ww_to_Z;trivial. - fold (ww_opp_carry (WW yh yl)). - rewrite (spec_ww_opp_carry (WW yh yl));simpl ww_to_Z;ring. - replace ([|xh|] * wB + [|xl|] - ([|yh|] * wB + [|yl|]) - 1) - with (([|xh|] - [|yh|]) * wB + ([|xl|] - [|yl|] - 1)). 2:ring. - generalize (spec_sub_carry_c xl yl);destruct (w_sub_carry_c xl yl)as[l|l]; - intros H;unfold interp_carry in H;rewrite <- H;rewrite spec_w_WW. - rewrite (mod_wwB w_digits w_to_Z spec_to_Z);rewrite spec_sub;trivial. - rewrite Z.add_assoc;rewrite <- Z.mul_add_distr_r. - rewrite (mod_wwB w_digits w_to_Z spec_to_Z);rewrite spec_sub_carry;trivial. - Qed. - -(* End DoubleProof. *) - -End DoubleSub. - - - - - diff --git a/theories/Numbers/Cyclic/Int31/Cyclic31.v b/theories/Numbers/Cyclic/Int31/Cyclic31.v index 0e58b81550..ba55003f7a 100644 --- a/theories/Numbers/Cyclic/Int31/Cyclic31.v +++ b/theories/Numbers/Cyclic/Int31/Cyclic31.v @@ -18,13 +18,16 @@ Require Export Int31. Require Import Znumtheory. Require Import Zgcd_alt. Require Import Zpow_facts. -Require Import BigNumPrelude. Require Import CyclicAxioms. Require Import ROmega. +Declare ML Module "int31_syntax_plugin". + Local Open Scope nat_scope. Local Open Scope int31_scope. +Local Hint Resolve Z.lt_gt Z.div_pos : zarith. + Section Basics. (** * Basic results about [iszero], [shiftl], [shiftr] *) @@ -455,12 +458,19 @@ Section Basics. rewrite Z.succ_double_spec; auto with zarith. Qed. - Lemma phi_bounded : forall x, (0 <= phi x < 2 ^ (Z.of_nat size))%Z. + Lemma phi_nonneg : forall x, (0 <= phi x)%Z. Proof. intros. rewrite <- phibis_aux_equiv. - split. apply phibis_aux_pos. + Qed. + + Hint Resolve phi_nonneg : zarith. + + Lemma phi_bounded : forall x, (0 <= phi x < 2 ^ (Z.of_nat size))%Z. + Proof. + intros. split; [auto with zarith|]. + rewrite <- phibis_aux_equiv. change x with (nshiftr x (size-size)). apply phibis_aux_bounded; auto. Qed. @@ -1624,6 +1634,37 @@ Section Int31_Specs. rewrite Z.mul_comm, Z_div_mult; auto with zarith. Qed. + Lemma shift_unshift_mod_2 : forall n p a, 0 <= p <= n -> + ((a * 2 ^ (n - p)) mod (2^n) / 2 ^ (n - p)) mod (2^n) = + a mod 2 ^ p. + Proof. + intros. + rewrite Zmod_small. + rewrite Zmod_eq by (auto with zarith). + unfold Z.sub at 1. + rewrite Z_div_plus_full_l + by (cut (0 < 2^(n-p)); auto with zarith). + assert (2^n = 2^(n-p)*2^p). + rewrite <- Zpower_exp by (auto with zarith). + replace (n-p+p) with n; auto with zarith. + rewrite H0. + rewrite <- Zdiv_Zdiv, Z_div_mult by (auto with zarith). + rewrite (Z.mul_comm (2^(n-p))), Z.mul_assoc. + rewrite <- Z.mul_opp_l. + rewrite Z_div_mult by (auto with zarith). + symmetry; apply Zmod_eq; auto with zarith. + + remember (a * 2 ^ (n - p)) as b. + destruct (Z_mod_lt b (2^n)); auto with zarith. + split. + apply Z_div_pos; auto with zarith. + apply Zdiv_lt_upper_bound; auto with zarith. + apply Z.lt_le_trans with (2^n); auto with zarith. + rewrite <- (Z.mul_1_r (2^n)) at 1. + apply Z.mul_le_mono_nonneg; auto with zarith. + cut (0 < 2 ^ (n-p)); auto with zarith. + Qed. + Lemma spec_pos_mod : forall w p, [|ZnZ.pos_mod p w|] = [|w|] mod (2 ^ [|p|]). Proof. @@ -1654,7 +1695,7 @@ Section Int31_Specs. rewrite spec_add_mul_div by (rewrite H4; auto with zarith). change [|0|] with 0%Z; rewrite Zdiv_0_l, Z.add_0_r. rewrite H4. - apply shift_unshift_mod_2; auto with zarith. + apply shift_unshift_mod_2; simpl; auto with zarith. Qed. @@ -1973,32 +2014,24 @@ Section Int31_Specs. assert (Hp2: 0 < [|2|]) by exact (eq_refl Lt). intros Hi Hj Hij H31 Hrec; rewrite sqrt31_step_def. rewrite spec_compare, div31_phi; auto. - case Z.compare_spec; auto; intros Hc; + case Z.compare_spec; auto; intros Hc; try (split; auto; apply sqrt_test_true; auto with zarith; fail). - apply Hrec; repeat rewrite div31_phi; auto with zarith. - replace [|(j + fst (i / j)%int31)|] with ([|j|] + [|i|] / [|j|]). - split. + assert (E : [|(j + fst (i / j)%int31)|] = [|j|] + [|i|] / [|j|]). + { rewrite spec_add, div31_phi; auto using Z.mod_small with zarith. } + apply Hrec; rewrite !div31_phi, E; auto using sqrt_main with zarith. + split; try apply sqrt_test_false; auto with zarith. apply Z.le_succ_l in Hj. change (1 <= [|j|]) in Hj. Z.le_elim Hj. - replace ([|j|] + [|i|]/[|j|]) with - (1 * 2 + (([|j|] - 2) + [|i|] / [|j|])); try ring. - rewrite Z_div_plus_full_l; auto with zarith. - assert (0 <= [|i|]/ [|j|]) by (apply Z_div_pos; auto with zarith). - assert (0 <= ([|j|] - 2 + [|i|] / [|j|]) / [|2|]) ; auto with zarith. - rewrite <- Hj, Zdiv_1_r. - replace (1 + [|i|])%Z with (1 * 2 + ([|i|] - 1))%Z; try ring. - rewrite Z_div_plus_full_l; auto with zarith. - assert (0 <= ([|i|] - 1) /2)%Z by (apply Z_div_pos; auto with zarith). - change ([|2|]) with 2%Z; auto with zarith. - apply sqrt_test_false; auto with zarith. - rewrite spec_add, div31_phi; auto. - symmetry; apply Zmod_small. - split; auto with zarith. - replace [|j + fst (i / j)%int31|] with ([|j|] + [|i|] / [|j|]). - apply sqrt_main; auto with zarith. - rewrite spec_add, div31_phi; auto. - symmetry; apply Zmod_small. - split; auto with zarith. + - replace ([|j|] + [|i|]/[|j|]) with + (1 * 2 + (([|j|] - 2) + [|i|] / [|j|])) by ring. + rewrite Z_div_plus_full_l; auto with zarith. + assert (0 <= [|i|]/ [|j|]) by auto with zarith. + assert (0 <= ([|j|] - 2 + [|i|] / [|j|]) / [|2|]); auto with zarith. + - rewrite <- Hj, Zdiv_1_r. + replace (1 + [|i|]) with (1 * 2 + ([|i|] - 1)) by ring. + rewrite Z_div_plus_full_l; auto with zarith. + assert (0 <= ([|i|] - 1) /2) by auto with zarith. + change ([|2|]) with 2; auto with zarith. Qed. Lemma iter31_sqrt_correct n rec i j: 0 < [|i|] -> 0 < [|j|] -> @@ -2078,11 +2111,12 @@ Section Int31_Specs. case (phi_bounded j); intros Hbj _. case (phi_bounded il); intros Hbil _. case (phi_bounded ih); intros Hbih Hbih1. - assert (([|ih|] < [|j|] + 1)%Z); auto with zarith. + assert ([|ih|] < [|j|] + 1); auto with zarith. apply Z.square_lt_simpl_nonneg; auto with zarith. - repeat rewrite <-Z.pow_2_r; apply Z.le_lt_trans with (2 := H1). - apply Z.le_trans with ([|ih|] * base)%Z; unfold phi2, base; - try rewrite Z.pow_2_r; auto with zarith. + rewrite <- ?Z.pow_2_r; apply Z.le_lt_trans with (2 := H1). + apply Z.le_trans with ([|ih|] * wB). + - rewrite ? Z.pow_2_r; auto with zarith. + - unfold phi2. change base with wB; auto with zarith. Qed. Lemma div312_phi ih il j: (2^30 <= [|j|] -> [|ih|] < [|j|] -> @@ -2104,90 +2138,89 @@ Section Int31_Specs. Proof. assert (Hp2: (0 < [|2|])%Z) by exact (eq_refl Lt). intros Hih Hj Hij Hrec; rewrite sqrt312_step_def. - assert (H1: ([|ih|] <= [|j|])%Z) by (apply sqrt312_lower_bound with il; auto). + assert (H1: ([|ih|] <= [|j|])) by (apply sqrt312_lower_bound with il; auto). case (phi_bounded ih); intros Hih1 _. case (phi_bounded il); intros Hil1 _. case (phi_bounded j); intros _ Hj1. assert (Hp3: (0 < phi2 ih il)). - unfold phi2; apply Z.lt_le_trans with ([|ih|] * base)%Z; auto with zarith. - apply Z.mul_pos_pos; auto with zarith. - apply Z.lt_le_trans with (2:= Hih); auto with zarith. + { unfold phi2; apply Z.lt_le_trans with ([|ih|] * base); auto with zarith. + apply Z.mul_pos_pos; auto with zarith. + apply Z.lt_le_trans with (2:= Hih); auto with zarith. } rewrite spec_compare. case Z.compare_spec; intros Hc1. - split; auto. - apply sqrt_test_true; auto. - unfold phi2, base; auto with zarith. - unfold phi2; rewrite Hc1. - assert (0 <= [|il|]/[|j|]) by (apply Z_div_pos; auto with zarith). - rewrite Z.mul_comm, Z_div_plus_full_l; unfold base; auto with zarith. - simpl wB in Hj1. unfold Z.pow_pos in Hj1. simpl in Hj1. auto with zarith. - case (Z.le_gt_cases (2 ^ 30) [|j|]); intros Hjj. - rewrite spec_compare; case Z.compare_spec; - rewrite div312_phi; auto; intros Hc; - try (split; auto; apply sqrt_test_true; auto with zarith; fail). - apply Hrec. - assert (Hf1: 0 <= phi2 ih il/ [|j|]) by (apply Z_div_pos; auto with zarith). - apply Z.le_succ_l in Hj. change (1 <= [|j|]) in Hj. - Z.le_elim Hj. - 2: contradict Hc; apply Z.le_ngt; rewrite <- Hj, Zdiv_1_r; auto with zarith. - assert (Hf3: 0 < ([|j|] + phi2 ih il / [|j|]) / 2). - replace ([|j|] + phi2 ih il/ [|j|])%Z with - (1 * 2 + (([|j|] - 2) + phi2 ih il / [|j|])); try ring. - rewrite Z_div_plus_full_l; auto with zarith. - assert (0 <= ([|j|] - 2 + phi2 ih il / [|j|]) / 2) ; auto with zarith. - assert (Hf4: ([|j|] + phi2 ih il / [|j|]) / 2 < [|j|]). - apply sqrt_test_false; auto with zarith. - generalize (spec_add_c j (fst (div3121 ih il j))). - unfold interp_carry; case add31c; intros r; - rewrite div312_phi; auto with zarith. - rewrite div31_phi; change [|2|] with 2%Z; auto with zarith. - intros HH; rewrite HH; clear HH; auto with zarith. - rewrite spec_add, div31_phi; change [|2|] with 2%Z; auto. - rewrite Z.mul_1_l; intros HH. - rewrite Z.add_comm, <- Z_div_plus_full_l; auto with zarith. - change (phi v30 * 2) with (2 ^ Z.of_nat size). - rewrite HH, Zmod_small; auto with zarith. - replace (phi - match j +c fst (div3121 ih il j) with - | C0 m1 => fst (m1 / 2)%int31 - | C1 m1 => fst (m1 / 2)%int31 + v30 - end) with ((([|j|] + (phi2 ih il)/([|j|]))/2)). - apply sqrt_main; auto with zarith. - generalize (spec_add_c j (fst (div3121 ih il j))). - unfold interp_carry; case add31c; intros r; - rewrite div312_phi; auto with zarith. - rewrite div31_phi; auto with zarith. - intros HH; rewrite HH; auto with zarith. - intros HH; rewrite <- HH. - change (1 * 2 ^ Z.of_nat size) with (phi (v30) * 2). - rewrite Z_div_plus_full_l; auto with zarith. - rewrite Z.add_comm. - rewrite spec_add, Zmod_small. - rewrite div31_phi; auto. - split; auto with zarith. - case (phi_bounded (fst (r/2)%int31)); - case (phi_bounded v30); auto with zarith. - rewrite div31_phi; change (phi 2) with 2%Z; auto. - change (2 ^Z.of_nat size) with (base/2 + phi v30). - assert (phi r / 2 < base/2); auto with zarith. - apply Z.mul_lt_mono_pos_r with 2; auto with zarith. - change (base/2 * 2) with base. - apply Z.le_lt_trans with (phi r). - rewrite Z.mul_comm; apply Z_mult_div_ge; auto with zarith. - case (phi_bounded r); auto with zarith. - contradict Hij; apply Z.le_ngt. - assert ((1 + [|j|]) <= 2 ^ 30); auto with zarith. - apply Z.le_trans with ((2 ^ 30) * (2 ^ 30)); auto with zarith. - assert (0 <= 1 + [|j|]); auto with zarith. - apply Z.mul_le_mono_nonneg; auto with zarith. - change ((2 ^ 30) * (2 ^ 30)) with ((2 ^ 29) * base). - apply Z.le_trans with ([|ih|] * base); auto with zarith. - unfold phi2, base; auto with zarith. - split; auto. - apply sqrt_test_true; auto. - unfold phi2, base; auto with zarith. - apply Z.le_ge; apply Z.le_trans with (([|j|] * base)/[|j|]). - rewrite Z.mul_comm, Z_div_mult; auto with zarith. - apply Z.ge_le; apply Z_div_ge; auto with zarith. + - split; auto. + apply sqrt_test_true; auto. + + unfold phi2, base; auto with zarith. + + unfold phi2; rewrite Hc1. + assert (0 <= [|il|]/[|j|]) by (apply Z_div_pos; auto with zarith). + rewrite Z.mul_comm, Z_div_plus_full_l; auto with zarith. + change base with wB. auto with zarith. + - case (Z.le_gt_cases (2 ^ 30) [|j|]); intros Hjj. + + rewrite spec_compare; case Z.compare_spec; + rewrite div312_phi; auto; intros Hc; + try (split; auto; apply sqrt_test_true; auto with zarith; fail). + apply Hrec. + * assert (Hf1: 0 <= phi2 ih il/ [|j|]) by auto with zarith. + apply Z.le_succ_l in Hj. change (1 <= [|j|]) in Hj. + Z.le_elim Hj; + [ | contradict Hc; apply Z.le_ngt; + rewrite <- Hj, Zdiv_1_r; auto with zarith ]. + assert (Hf3: 0 < ([|j|] + phi2 ih il / [|j|]) / 2). + { replace ([|j|] + phi2 ih il/ [|j|]) with + (1 * 2 + (([|j|] - 2) + phi2 ih il / [|j|])); try ring. + rewrite Z_div_plus_full_l; auto with zarith. + assert (0 <= ([|j|] - 2 + phi2 ih il / [|j|]) / 2) ; + auto with zarith. } + assert (Hf4: ([|j|] + phi2 ih il / [|j|]) / 2 < [|j|]). + { apply sqrt_test_false; auto with zarith. } + generalize (spec_add_c j (fst (div3121 ih il j))). + unfold interp_carry; case add31c; intros r; + rewrite div312_phi; auto with zarith. + { rewrite div31_phi; change [|2|] with 2; auto with zarith. + intros HH; rewrite HH; clear HH; auto with zarith. } + { rewrite spec_add, div31_phi; change [|2|] with 2; auto. + rewrite Z.mul_1_l; intros HH. + rewrite Z.add_comm, <- Z_div_plus_full_l; auto with zarith. + change (phi v30 * 2) with (2 ^ Z.of_nat size). + rewrite HH, Zmod_small; auto with zarith. } + * replace (phi _) with (([|j|] + (phi2 ih il)/([|j|]))/2); + [ apply sqrt_main; auto with zarith | ]. + generalize (spec_add_c j (fst (div3121 ih il j))). + unfold interp_carry; case add31c; intros r; + rewrite div312_phi; auto with zarith. + { rewrite div31_phi; auto with zarith. + intros HH; rewrite HH; auto with zarith. } + { intros HH; rewrite <- HH. + change (1 * 2 ^ Z.of_nat size) with (phi (v30) * 2). + rewrite Z_div_plus_full_l; auto with zarith. + rewrite Z.add_comm. + rewrite spec_add, Zmod_small. + - rewrite div31_phi; auto. + - split; auto with zarith. + + case (phi_bounded (fst (r/2)%int31)); + case (phi_bounded v30); auto with zarith. + + rewrite div31_phi; change (phi 2) with 2; auto. + change (2 ^Z.of_nat size) with (base/2 + phi v30). + assert (phi r / 2 < base/2); auto with zarith. + apply Z.mul_lt_mono_pos_r with 2; auto with zarith. + change (base/2 * 2) with base. + apply Z.le_lt_trans with (phi r). + * rewrite Z.mul_comm; apply Z_mult_div_ge; auto with zarith. + * case (phi_bounded r); auto with zarith. } + + contradict Hij; apply Z.le_ngt. + assert ((1 + [|j|]) <= 2 ^ 30); auto with zarith. + apply Z.le_trans with ((2 ^ 30) * (2 ^ 30)); auto with zarith. + * assert (0 <= 1 + [|j|]); auto with zarith. + apply Z.mul_le_mono_nonneg; auto with zarith. + * change ((2 ^ 30) * (2 ^ 30)) with ((2 ^ 29) * base). + apply Z.le_trans with ([|ih|] * base); + change wB with base in *; auto with zarith. + unfold phi2, base; auto with zarith. + - split; auto. + apply sqrt_test_true; auto. + + unfold phi2, base; auto with zarith. + + apply Z.le_ge; apply Z.le_trans with (([|j|] * base)/[|j|]). + * rewrite Z.mul_comm, Z_div_mult; auto with zarith. + * apply Z.ge_le; apply Z_div_ge; auto with zarith. Qed. Lemma iter312_sqrt_correct n rec ih il j: @@ -2209,7 +2242,7 @@ Section Int31_Specs. intros j3 Hj3 Hpj3. apply HHrec; auto. rewrite Nat2Z.inj_succ, Z.pow_succ_r. - apply Z.le_trans with (2 ^Z.of_nat n + [|j2|])%Z; auto with zarith. + apply Z.le_trans with (2 ^Z.of_nat n + [|j2|]); auto with zarith. apply Nat2Z.is_nonneg. Qed. diff --git a/theories/Numbers/Cyclic/ZModulo/ZModulo.v b/theories/Numbers/Cyclic/ZModulo/ZModulo.v index 04fc5a8dfa..a3d7edbf4b 100644 --- a/theories/Numbers/Cyclic/ZModulo/ZModulo.v +++ b/theories/Numbers/Cyclic/ZModulo/ZModulo.v @@ -18,7 +18,7 @@ Set Implicit Arguments. Require Import Bool. Require Import ZArith. Require Import Znumtheory. -Require Import BigNumPrelude. +Require Import Zpow_facts. Require Import DoubleType. Require Import CyclicAxioms. @@ -48,13 +48,14 @@ Section ZModulo. Lemma spec_more_than_1_digit: 1 < Zpos digits. Proof. - generalize digits_ne_1; destruct digits; auto. + generalize digits_ne_1; destruct digits; red; auto. destruct 1; auto. Qed. Let digits_gt_1 := spec_more_than_1_digit. Lemma wB_pos : wB > 0. Proof. + apply Z.lt_gt. unfold wB, base; auto with zarith. Qed. Hint Resolve wB_pos. @@ -558,7 +559,7 @@ Section ZModulo. apply Zmod_small. generalize (Z_mod_lt [|w|] (2 ^ [|p|])); intros. split. - destruct H; auto with zarith. + destruct H; auto using Z.lt_gt with zarith. apply Z.le_lt_trans with [|w|]; auto with zarith. apply Zmod_le; auto with zarith. Qed. diff --git a/theories/Numbers/Integer/BigZ/BigZ.v b/theories/Numbers/Integer/BigZ/BigZ.v deleted file mode 100644 index 7c76011f21..0000000000 --- a/theories/Numbers/Integer/BigZ/BigZ.v +++ /dev/null @@ -1,208 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) -(* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) -(************************************************************************) - -Require Export BigN. -Require Import ZProperties ZDivFloor ZSig ZSigZAxioms ZMake. - -(** * [BigZ] : arbitrary large efficient integers. - - The following [BigZ] module regroups both the operations and - all the abstract properties: - - - [ZMake.Make BigN] provides the operations and basic specs w.r.t. ZArith - - [ZTypeIsZAxioms] shows (mainly) that these operations implement - the interface [ZAxioms] - - [ZProp] adds all generic properties derived from [ZAxioms] - - [MinMax*Properties] provides properties of [min] and [max] - -*) - -Delimit Scope bigZ_scope with bigZ. - -Module BigZ <: ZType <: OrderedTypeFull <: TotalOrder := - ZMake.Make BigN - <+ ZTypeIsZAxioms - <+ ZBasicProp [no inline] <+ ZExtraProp [no inline] - <+ HasEqBool2Dec [no inline] - <+ MinMaxLogicalProperties [no inline] - <+ MinMaxDecProperties [no inline]. - -(** For precision concerning the above scope handling, see comment in BigN *) - -(** Notations about [BigZ] *) - -Local Open Scope bigZ_scope. - -Notation bigZ := BigZ.t. -Bind Scope bigZ_scope with bigZ BigZ.t BigZ.t_. -Arguments BigZ.Pos _%bigN. -Arguments BigZ.Neg _%bigN. -Local Notation "0" := BigZ.zero : bigZ_scope. -Local Notation "1" := BigZ.one : bigZ_scope. -Local Notation "2" := BigZ.two : bigZ_scope. -Infix "+" := BigZ.add : bigZ_scope. -Infix "-" := BigZ.sub : bigZ_scope. -Notation "- x" := (BigZ.opp x) : bigZ_scope. -Infix "*" := BigZ.mul : bigZ_scope. -Infix "/" := BigZ.div : bigZ_scope. -Infix "^" := BigZ.pow : bigZ_scope. -Infix "?=" := BigZ.compare : bigZ_scope. -Infix "=?" := BigZ.eqb (at level 70, no associativity) : bigZ_scope. -Infix "<=?" := BigZ.leb (at level 70, no associativity) : bigZ_scope. -Infix "<?" := BigZ.ltb (at level 70, no associativity) : bigZ_scope. -Infix "==" := BigZ.eq (at level 70, no associativity) : bigZ_scope. -Notation "x != y" := (~x==y) (at level 70, no associativity) : bigZ_scope. -Infix "<" := BigZ.lt : bigZ_scope. -Infix "<=" := BigZ.le : bigZ_scope. -Notation "x > y" := (y < x) (only parsing) : bigZ_scope. -Notation "x >= y" := (y <= x) (only parsing) : bigZ_scope. -Notation "x < y < z" := (x<y /\ y<z) : bigZ_scope. -Notation "x < y <= z" := (x<y /\ y<=z) : bigZ_scope. -Notation "x <= y < z" := (x<=y /\ y<z) : bigZ_scope. -Notation "x <= y <= z" := (x<=y /\ y<=z) : bigZ_scope. -Notation "[ i ]" := (BigZ.to_Z i) : bigZ_scope. -Infix "mod" := BigZ.modulo (at level 40, no associativity) : bigZ_scope. -Infix "÷" := BigZ.quot (at level 40, left associativity) : bigZ_scope. - -(** Some additional results about [BigZ] *) - -Theorem spec_to_Z: forall n : bigZ, - BigN.to_Z (BigZ.to_N n) = ((Z.sgn [n]) * [n])%Z. -Proof. -intros n; case n; simpl; intros p; - generalize (BigN.spec_pos p); case (BigN.to_Z p); auto. -intros p1 H1; case H1; auto. -intros p1 H1; case H1; auto. -Qed. - -Theorem spec_to_N n: - ([n] = Z.sgn [n] * (BigN.to_Z (BigZ.to_N n)))%Z. -Proof. -case n; simpl; intros p; - generalize (BigN.spec_pos p); case (BigN.to_Z p); auto. -intros p1 H1; case H1; auto. -intros p1 H1; case H1; auto. -Qed. - -Theorem spec_to_Z_pos: forall n, (0 <= [n])%Z -> - BigN.to_Z (BigZ.to_N n) = [n]. -Proof. -intros n; case n; simpl; intros p; - generalize (BigN.spec_pos p); case (BigN.to_Z p); auto. -intros p1 _ H1; case H1; auto. -intros p1 H1; case H1; auto. -Qed. - -(** [BigZ] is a ring *) - -Lemma BigZring : - ring_theory 0 1 BigZ.add BigZ.mul BigZ.sub BigZ.opp BigZ.eq. -Proof. -constructor. -exact BigZ.add_0_l. exact BigZ.add_comm. exact BigZ.add_assoc. -exact BigZ.mul_1_l. exact BigZ.mul_comm. exact BigZ.mul_assoc. -exact BigZ.mul_add_distr_r. -symmetry. apply BigZ.add_opp_r. -exact BigZ.add_opp_diag_r. -Qed. - -Lemma BigZeqb_correct : forall x y, (x =? y) = true -> x==y. -Proof. now apply BigZ.eqb_eq. Qed. - -Definition BigZ_of_N n := BigZ.of_Z (Z.of_N n). - -Lemma BigZpower : power_theory 1 BigZ.mul BigZ.eq BigZ_of_N BigZ.pow. -Proof. -constructor. -intros. unfold BigZ.eq, BigZ_of_N. rewrite BigZ.spec_pow, BigZ.spec_of_Z. -rewrite Zpower_theory.(rpow_pow_N). -destruct n; simpl. reflexivity. -induction p; simpl; intros; BigZ.zify; rewrite ?IHp; auto. -Qed. - -Lemma BigZdiv : div_theory BigZ.eq BigZ.add BigZ.mul (@id _) - (fun a b => if b =? 0 then (0,a) else BigZ.div_eucl a b). -Proof. -constructor. unfold id. intros a b. -BigZ.zify. -case Z.eqb_spec. -BigZ.zify. auto with zarith. -intros NEQ. -generalize (BigZ.spec_div_eucl a b). -generalize (Z_div_mod_full [a] [b] NEQ). -destruct BigZ.div_eucl as (q,r), Z.div_eucl as (q',r'). -intros (EQ,_). injection 1 as EQr EQq. -BigZ.zify. rewrite EQr, EQq; auto. -Qed. - -(** Detection of constants *) - -Ltac isBigZcst t := - match t with - | BigZ.Pos ?t => isBigNcst t - | BigZ.Neg ?t => isBigNcst t - | BigZ.zero => constr:(true) - | BigZ.one => constr:(true) - | BigZ.two => constr:(true) - | BigZ.minus_one => constr:(true) - | _ => constr:(false) - end. - -Ltac BigZcst t := - match isBigZcst t with - | true => constr:(t) - | false => constr:(NotConstant) - end. - -Ltac BigZ_to_N t := - match t with - | BigZ.Pos ?t => BigN_to_N t - | BigZ.zero => constr:(0%N) - | BigZ.one => constr:(1%N) - | BigZ.two => constr:(2%N) - | _ => constr:(NotConstant) - end. - -(** Registration for the "ring" tactic *) - -Add Ring BigZr : BigZring - (decidable BigZeqb_correct, - constants [BigZcst], - power_tac BigZpower [BigZ_to_N], - div BigZdiv). - -Section TestRing. -Let test : forall x y, 1 + x*y + x^2 + 1 == 1*1 + 1 + (y + 1*x)*x. -Proof. -intros. ring_simplify. reflexivity. -Qed. -Let test' : forall x y, 1 + x*y + x^2 - 1*1 - y*x + 1*(-x)*x == 0. -Proof. -intros. ring_simplify. reflexivity. -Qed. -End TestRing. - -(** [BigZ] also benefits from an "order" tactic *) - -Ltac bigZ_order := BigZ.order. - -Section TestOrder. -Let test : forall x y : bigZ, x<=y -> y<=x -> x==y. -Proof. bigZ_order. Qed. -End TestOrder. - -(** We can use at least a bit of (r)omega by translating to [Z]. *) - -Section TestOmega. -Let test : forall x y : bigZ, x<=y -> y<=x -> x==y. -Proof. intros x y. BigZ.zify. omega. Qed. -End TestOmega. - -(** Todo: micromega *) diff --git a/theories/Numbers/Integer/BigZ/ZMake.v b/theories/Numbers/Integer/BigZ/ZMake.v deleted file mode 100644 index fec6e06837..0000000000 --- a/theories/Numbers/Integer/BigZ/ZMake.v +++ /dev/null @@ -1,759 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) -(* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) -(************************************************************************) - -Require Import ZArith. -Require Import BigNumPrelude. -Require Import NSig. -Require Import ZSig. - -Open Scope Z_scope. - -(** * ZMake - - A generic transformation from a structure of natural numbers - [NSig.NType] to a structure of integers [ZSig.ZType]. -*) - -Module Make (NN:NType) <: ZType. - - Inductive t_ := - | Pos : NN.t -> t_ - | Neg : NN.t -> t_. - - Definition t := t_. - - Definition zero := Pos NN.zero. - Definition one := Pos NN.one. - Definition two := Pos NN.two. - Definition minus_one := Neg NN.one. - - Definition of_Z x := - match x with - | Zpos x => Pos (NN.of_N (Npos x)) - | Z0 => zero - | Zneg x => Neg (NN.of_N (Npos x)) - end. - - Definition to_Z x := - match x with - | Pos nx => NN.to_Z nx - | Neg nx => Z.opp (NN.to_Z nx) - end. - - Theorem spec_of_Z: forall x, to_Z (of_Z x) = x. - Proof. - intros x; case x; unfold to_Z, of_Z, zero. - exact NN.spec_0. - intros; rewrite NN.spec_of_N; auto. - intros; rewrite NN.spec_of_N; auto. - Qed. - - Definition eq x y := (to_Z x = to_Z y). - - Theorem spec_0: to_Z zero = 0. - exact NN.spec_0. - Qed. - - Theorem spec_1: to_Z one = 1. - exact NN.spec_1. - Qed. - - Theorem spec_2: to_Z two = 2. - exact NN.spec_2. - Qed. - - Theorem spec_m1: to_Z minus_one = -1. - simpl; rewrite NN.spec_1; auto. - Qed. - - Definition compare x y := - match x, y with - | Pos nx, Pos ny => NN.compare nx ny - | Pos nx, Neg ny => - match NN.compare nx NN.zero with - | Gt => Gt - | _ => NN.compare ny NN.zero - end - | Neg nx, Pos ny => - match NN.compare NN.zero nx with - | Lt => Lt - | _ => NN.compare NN.zero ny - end - | Neg nx, Neg ny => NN.compare ny nx - end. - - Theorem spec_compare : - forall x y, compare x y = Z.compare (to_Z x) (to_Z y). - Proof. - unfold compare, to_Z. - destruct x as [x|x], y as [y|y]; - rewrite ?NN.spec_compare, ?NN.spec_0, ?Z.compare_opp; auto; - assert (Hx:=NN.spec_pos x); assert (Hy:=NN.spec_pos y); - set (X:=NN.to_Z x) in *; set (Y:=NN.to_Z y) in *; clearbody X Y. - - destruct (Z.compare_spec X 0) as [EQ|LT|GT]. - + rewrite <- Z.opp_0 in EQ. now rewrite EQ, Z.compare_opp. - + exfalso. omega. - + symmetry. change (X > -Y). omega. - - destruct (Z.compare_spec 0 X) as [EQ|LT|GT]. - + rewrite <- EQ, Z.opp_0; auto. - + symmetry. change (-X < Y). omega. - + exfalso. omega. - Qed. - - Definition eqb x y := - match compare x y with - | Eq => true - | _ => false - end. - - Theorem spec_eqb x y : eqb x y = Z.eqb (to_Z x) (to_Z y). - Proof. - apply Bool.eq_iff_eq_true. - unfold eqb. rewrite Z.eqb_eq, <- Z.compare_eq_iff, spec_compare. - split; [now destruct Z.compare | now intros ->]. - Qed. - - Definition lt n m := to_Z n < to_Z m. - Definition le n m := to_Z n <= to_Z m. - - - Definition ltb (x y : t) : bool := - match compare x y with - | Lt => true - | _ => false - end. - - Theorem spec_ltb x y : ltb x y = Z.ltb (to_Z x) (to_Z y). - Proof. - apply Bool.eq_iff_eq_true. - rewrite Z.ltb_lt. unfold Z.lt, ltb. rewrite spec_compare. - split; [now destruct Z.compare | now intros ->]. - Qed. - - Definition leb (x y : t) : bool := - match compare x y with - | Gt => false - | _ => true - end. - - Theorem spec_leb x y : leb x y = Z.leb (to_Z x) (to_Z y). - Proof. - apply Bool.eq_iff_eq_true. - rewrite Z.leb_le. unfold Z.le, leb. rewrite spec_compare. - now destruct Z.compare; split. - Qed. - - Definition min n m := match compare n m with Gt => m | _ => n end. - Definition max n m := match compare n m with Lt => m | _ => n end. - - Theorem spec_min : forall n m, to_Z (min n m) = Z.min (to_Z n) (to_Z m). - Proof. - unfold min, Z.min. intros. rewrite spec_compare. destruct Z.compare; auto. - Qed. - - Theorem spec_max : forall n m, to_Z (max n m) = Z.max (to_Z n) (to_Z m). - Proof. - unfold max, Z.max. intros. rewrite spec_compare. destruct Z.compare; auto. - Qed. - - Definition to_N x := - match x with - | Pos nx => nx - | Neg nx => nx - end. - - Definition abs x := Pos (to_N x). - - Theorem spec_abs: forall x, to_Z (abs x) = Z.abs (to_Z x). - Proof. - intros x; case x; clear x; intros x; assert (F:=NN.spec_pos x). - simpl; rewrite Z.abs_eq; auto. - simpl; rewrite Z.abs_neq; simpl; auto with zarith. - Qed. - - Definition opp x := - match x with - | Pos nx => Neg nx - | Neg nx => Pos nx - end. - - Theorem spec_opp: forall x, to_Z (opp x) = - to_Z x. - Proof. - intros x; case x; simpl; auto with zarith. - Qed. - - Definition succ x := - match x with - | Pos n => Pos (NN.succ n) - | Neg n => - match NN.compare NN.zero n with - | Lt => Neg (NN.pred n) - | _ => one - end - end. - - Theorem spec_succ: forall n, to_Z (succ n) = to_Z n + 1. - Proof. - intros x; case x; clear x; intros x. - exact (NN.spec_succ x). - simpl. rewrite NN.spec_compare. case Z.compare_spec; rewrite ?NN.spec_0; simpl. - intros HH; rewrite <- HH; rewrite NN.spec_1; ring. - intros HH; rewrite NN.spec_pred, Z.max_r; auto with zarith. - generalize (NN.spec_pos x); auto with zarith. - Qed. - - Definition add x y := - match x, y with - | Pos nx, Pos ny => Pos (NN.add nx ny) - | Pos nx, Neg ny => - match NN.compare nx ny with - | Gt => Pos (NN.sub nx ny) - | Eq => zero - | Lt => Neg (NN.sub ny nx) - end - | Neg nx, Pos ny => - match NN.compare nx ny with - | Gt => Neg (NN.sub nx ny) - | Eq => zero - | Lt => Pos (NN.sub ny nx) - end - | Neg nx, Neg ny => Neg (NN.add nx ny) - end. - - Theorem spec_add: forall x y, to_Z (add x y) = to_Z x + to_Z y. - Proof. - unfold add, to_Z; intros [x | x] [y | y]; - try (rewrite NN.spec_add; auto with zarith); - rewrite NN.spec_compare; case Z.compare_spec; - unfold zero; rewrite ?NN.spec_0, ?NN.spec_sub; omega with *. - Qed. - - Definition pred x := - match x with - | Pos nx => - match NN.compare NN.zero nx with - | Lt => Pos (NN.pred nx) - | _ => minus_one - end - | Neg nx => Neg (NN.succ nx) - end. - - Theorem spec_pred: forall x, to_Z (pred x) = to_Z x - 1. - Proof. - unfold pred, to_Z, minus_one; intros [x | x]; - try (rewrite NN.spec_succ; ring). - rewrite NN.spec_compare; case Z.compare_spec; - rewrite ?NN.spec_0, ?NN.spec_1, ?NN.spec_pred; - generalize (NN.spec_pos x); omega with *. - Qed. - - Definition sub x y := - match x, y with - | Pos nx, Pos ny => - match NN.compare nx ny with - | Gt => Pos (NN.sub nx ny) - | Eq => zero - | Lt => Neg (NN.sub ny nx) - end - | Pos nx, Neg ny => Pos (NN.add nx ny) - | Neg nx, Pos ny => Neg (NN.add nx ny) - | Neg nx, Neg ny => - match NN.compare nx ny with - | Gt => Neg (NN.sub nx ny) - | Eq => zero - | Lt => Pos (NN.sub ny nx) - end - end. - - Theorem spec_sub: forall x y, to_Z (sub x y) = to_Z x - to_Z y. - Proof. - unfold sub, to_Z; intros [x | x] [y | y]; - try (rewrite NN.spec_add; auto with zarith); - rewrite NN.spec_compare; case Z.compare_spec; - unfold zero; rewrite ?NN.spec_0, ?NN.spec_sub; omega with *. - Qed. - - Definition mul x y := - match x, y with - | Pos nx, Pos ny => Pos (NN.mul nx ny) - | Pos nx, Neg ny => Neg (NN.mul nx ny) - | Neg nx, Pos ny => Neg (NN.mul nx ny) - | Neg nx, Neg ny => Pos (NN.mul nx ny) - end. - - Theorem spec_mul: forall x y, to_Z (mul x y) = to_Z x * to_Z y. - Proof. - unfold mul, to_Z; intros [x | x] [y | y]; rewrite NN.spec_mul; ring. - Qed. - - Definition square x := - match x with - | Pos nx => Pos (NN.square nx) - | Neg nx => Pos (NN.square nx) - end. - - Theorem spec_square: forall x, to_Z (square x) = to_Z x * to_Z x. - Proof. - unfold square, to_Z; intros [x | x]; rewrite NN.spec_square; ring. - Qed. - - Definition pow_pos x p := - match x with - | Pos nx => Pos (NN.pow_pos nx p) - | Neg nx => - match p with - | xH => x - | xO _ => Pos (NN.pow_pos nx p) - | xI _ => Neg (NN.pow_pos nx p) - end - end. - - Theorem spec_pow_pos: forall x n, to_Z (pow_pos x n) = to_Z x ^ Zpos n. - Proof. - assert (F0: forall x, (-x)^2 = x^2). - intros x; rewrite Z.pow_2_r; ring. - unfold pow_pos, to_Z; intros [x | x] [p | p |]; - try rewrite NN.spec_pow_pos; try ring. - assert (F: 0 <= 2 * Zpos p). - assert (0 <= Zpos p); auto with zarith. - rewrite Pos2Z.inj_xI; repeat rewrite Zpower_exp; auto with zarith. - repeat rewrite Z.pow_mul_r; auto with zarith. - rewrite F0; ring. - assert (F: 0 <= 2 * Zpos p). - assert (0 <= Zpos p); auto with zarith. - rewrite Pos2Z.inj_xO; repeat rewrite Zpower_exp; auto with zarith. - repeat rewrite Z.pow_mul_r; auto with zarith. - rewrite F0; ring. - Qed. - - Definition pow_N x n := - match n with - | N0 => one - | Npos p => pow_pos x p - end. - - Theorem spec_pow_N: forall x n, to_Z (pow_N x n) = to_Z x ^ Z.of_N n. - Proof. - destruct n; simpl. apply NN.spec_1. - apply spec_pow_pos. - Qed. - - Definition pow x y := - match to_Z y with - | Z0 => one - | Zpos p => pow_pos x p - | Zneg p => zero - end. - - Theorem spec_pow: forall x y, to_Z (pow x y) = to_Z x ^ to_Z y. - Proof. - intros. unfold pow. destruct (to_Z y); simpl. - apply NN.spec_1. - apply spec_pow_pos. - apply NN.spec_0. - Qed. - - Definition log2 x := - match x with - | Pos nx => Pos (NN.log2 nx) - | Neg nx => zero - end. - - Theorem spec_log2: forall x, to_Z (log2 x) = Z.log2 (to_Z x). - Proof. - intros. destruct x as [p|p]; simpl. apply NN.spec_log2. - rewrite NN.spec_0. - destruct (Z_le_lt_eq_dec _ _ (NN.spec_pos p)) as [LT|EQ]. - rewrite Z.log2_nonpos; auto with zarith. - now rewrite <- EQ. - Qed. - - Definition sqrt x := - match x with - | Pos nx => Pos (NN.sqrt nx) - | Neg nx => Neg NN.zero - end. - - Theorem spec_sqrt: forall x, to_Z (sqrt x) = Z.sqrt (to_Z x). - Proof. - destruct x as [p|p]; simpl. - apply NN.spec_sqrt. - rewrite NN.spec_0. - destruct (Z_le_lt_eq_dec _ _ (NN.spec_pos p)) as [LT|EQ]. - rewrite Z.sqrt_neg; auto with zarith. - now rewrite <- EQ. - Qed. - - Definition div_eucl x y := - match x, y with - | Pos nx, Pos ny => - let (q, r) := NN.div_eucl nx ny in - (Pos q, Pos r) - | Pos nx, Neg ny => - let (q, r) := NN.div_eucl nx ny in - if NN.eqb NN.zero r - then (Neg q, zero) - else (Neg (NN.succ q), Neg (NN.sub ny r)) - | Neg nx, Pos ny => - let (q, r) := NN.div_eucl nx ny in - if NN.eqb NN.zero r - then (Neg q, zero) - else (Neg (NN.succ q), Pos (NN.sub ny r)) - | Neg nx, Neg ny => - let (q, r) := NN.div_eucl nx ny in - (Pos q, Neg r) - end. - - Ltac break_nonneg x px EQx := - let H := fresh "H" in - assert (H:=NN.spec_pos x); - destruct (NN.to_Z x) as [|px|px] eqn:EQx; - [clear H|clear H|elim H; reflexivity]. - - Theorem spec_div_eucl: forall x y, - let (q,r) := div_eucl x y in - (to_Z q, to_Z r) = Z.div_eucl (to_Z x) (to_Z y). - Proof. - unfold div_eucl, to_Z. intros [x | x] [y | y]. - (* Pos Pos *) - generalize (NN.spec_div_eucl x y); destruct (NN.div_eucl x y); auto. - (* Pos Neg *) - generalize (NN.spec_div_eucl x y); destruct (NN.div_eucl x y) as (q,r). - break_nonneg x px EQx; break_nonneg y py EQy; - try (injection 1 as Hq Hr; rewrite NN.spec_eqb, NN.spec_0, Hr; - simpl; rewrite Hq, NN.spec_0; auto). - change (- Zpos py) with (Zneg py). - assert (GT : Zpos py > 0) by (compute; auto). - generalize (Z_div_mod (Zpos px) (Zpos py) GT). - unfold Z.div_eucl. destruct (Z.pos_div_eucl px (Zpos py)) as (q',r'). - intros (EQ,MOD). injection 1 as Hq' Hr'. - rewrite NN.spec_eqb, NN.spec_0, Hr'. - break_nonneg r pr EQr. - subst; simpl. rewrite NN.spec_0; auto. - subst. lazy iota beta delta [Z.eqb]. - rewrite NN.spec_sub, NN.spec_succ, EQy, EQr. f_equal. omega with *. - (* Neg Pos *) - generalize (NN.spec_div_eucl x y); destruct (NN.div_eucl x y) as (q,r). - break_nonneg x px EQx; break_nonneg y py EQy; - try (injection 1 as Hq Hr; rewrite NN.spec_eqb, NN.spec_0, Hr; - simpl; rewrite Hq, NN.spec_0; auto). - change (- Zpos px) with (Zneg px). - assert (GT : Zpos py > 0) by (compute; auto). - generalize (Z_div_mod (Zpos px) (Zpos py) GT). - unfold Z.div_eucl. destruct (Z.pos_div_eucl px (Zpos py)) as (q',r'). - intros (EQ,MOD). injection 1 as Hq' Hr'. - rewrite NN.spec_eqb, NN.spec_0, Hr'. - break_nonneg r pr EQr. - subst; simpl. rewrite NN.spec_0; auto. - subst. lazy iota beta delta [Z.eqb]. - rewrite NN.spec_sub, NN.spec_succ, EQy, EQr. f_equal. omega with *. - (* Neg Neg *) - generalize (NN.spec_div_eucl x y); destruct (NN.div_eucl x y) as (q,r). - break_nonneg x px EQx; break_nonneg y py EQy; - try (injection 1 as -> ->; auto). - simpl. intros <-; auto. - Qed. - - Definition div x y := fst (div_eucl x y). - - Definition spec_div: forall x y, - to_Z (div x y) = to_Z x / to_Z y. - Proof. - intros x y; generalize (spec_div_eucl x y); unfold div, Z.div. - case div_eucl; case Z.div_eucl; simpl; auto. - intros q r q11 r1 H; injection H; auto. - Qed. - - Definition modulo x y := snd (div_eucl x y). - - Theorem spec_modulo: - forall x y, to_Z (modulo x y) = to_Z x mod to_Z y. - Proof. - intros x y; generalize (spec_div_eucl x y); unfold modulo, Z.modulo. - case div_eucl; case Z.div_eucl; simpl; auto. - intros q r q11 r1 H; injection H; auto. - Qed. - - Definition quot x y := - match x, y with - | Pos nx, Pos ny => Pos (NN.div nx ny) - | Pos nx, Neg ny => Neg (NN.div nx ny) - | Neg nx, Pos ny => Neg (NN.div nx ny) - | Neg nx, Neg ny => Pos (NN.div nx ny) - end. - - Definition rem x y := - if eqb y zero then x - else - match x, y with - | Pos nx, Pos ny => Pos (NN.modulo nx ny) - | Pos nx, Neg ny => Pos (NN.modulo nx ny) - | Neg nx, Pos ny => Neg (NN.modulo nx ny) - | Neg nx, Neg ny => Neg (NN.modulo nx ny) - end. - - Lemma spec_quot : forall x y, to_Z (quot x y) = (to_Z x) ÷ (to_Z y). - Proof. - intros [x|x] [y|y]; simpl; symmetry; rewrite NN.spec_div; - (* Nota: we rely here on [forall a b, a ÷ 0 = b / 0] *) - destruct (Z.eq_dec (NN.to_Z y) 0) as [EQ|NEQ]; - try (rewrite EQ; now destruct (NN.to_Z x)); - rewrite ?Z.quot_opp_r, ?Z.quot_opp_l, ?Z.opp_involutive, ?Z.opp_inj_wd; - trivial; apply Z.quot_div_nonneg; - generalize (NN.spec_pos x) (NN.spec_pos y); Z.order. - Qed. - - Lemma spec_rem : forall x y, - to_Z (rem x y) = Z.rem (to_Z x) (to_Z y). - Proof. - intros x y. unfold rem. rewrite spec_eqb, spec_0. - case Z.eqb_spec; intros Hy. - (* Nota: we rely here on [Z.rem a 0 = a] *) - rewrite Hy. now destruct (to_Z x). - destruct x as [x|x], y as [y|y]; simpl in *; symmetry; - rewrite ?Z.eq_opp_l, ?Z.opp_0 in Hy; - rewrite NN.spec_modulo, ?Z.rem_opp_r, ?Z.rem_opp_l, ?Z.opp_involutive, - ?Z.opp_inj_wd; - trivial; apply Z.rem_mod_nonneg; - generalize (NN.spec_pos x) (NN.spec_pos y); Z.order. - Qed. - - Definition gcd x y := - match x, y with - | Pos nx, Pos ny => Pos (NN.gcd nx ny) - | Pos nx, Neg ny => Pos (NN.gcd nx ny) - | Neg nx, Pos ny => Pos (NN.gcd nx ny) - | Neg nx, Neg ny => Pos (NN.gcd nx ny) - end. - - Theorem spec_gcd: forall a b, to_Z (gcd a b) = Z.gcd (to_Z a) (to_Z b). - Proof. - unfold gcd, Z.gcd, to_Z; intros [x | x] [y | y]; rewrite NN.spec_gcd; unfold Z.gcd; - auto; case NN.to_Z; simpl; auto with zarith; - try rewrite Z.abs_opp; auto; - case NN.to_Z; simpl; auto with zarith. - Qed. - - Definition sgn x := - match compare zero x with - | Lt => one - | Eq => zero - | Gt => minus_one - end. - - Lemma spec_sgn : forall x, to_Z (sgn x) = Z.sgn (to_Z x). - Proof. - intros. unfold sgn. rewrite spec_compare. case Z.compare_spec. - rewrite spec_0. intros <-; auto. - rewrite spec_0, spec_1. symmetry. rewrite Z.sgn_pos_iff; auto. - rewrite spec_0, spec_m1. symmetry. rewrite Z.sgn_neg_iff; auto with zarith. - Qed. - - Definition even z := - match z with - | Pos n => NN.even n - | Neg n => NN.even n - end. - - Definition odd z := - match z with - | Pos n => NN.odd n - | Neg n => NN.odd n - end. - - Lemma spec_even : forall z, even z = Z.even (to_Z z). - Proof. - intros [n|n]; simpl; rewrite NN.spec_even; trivial. - destruct (NN.to_Z n) as [|p|p]; now try destruct p. - Qed. - - Lemma spec_odd : forall z, odd z = Z.odd (to_Z z). - Proof. - intros [n|n]; simpl; rewrite NN.spec_odd; trivial. - destruct (NN.to_Z n) as [|p|p]; now try destruct p. - Qed. - - Definition norm_pos z := - match z with - | Pos _ => z - | Neg n => if NN.eqb n NN.zero then Pos n else z - end. - - Definition testbit a n := - match norm_pos n, norm_pos a with - | Pos p, Pos a => NN.testbit a p - | Pos p, Neg a => negb (NN.testbit (NN.pred a) p) - | Neg p, _ => false - end. - - Definition shiftl a n := - match norm_pos a, n with - | Pos a, Pos n => Pos (NN.shiftl a n) - | Pos a, Neg n => Pos (NN.shiftr a n) - | Neg a, Pos n => Neg (NN.shiftl a n) - | Neg a, Neg n => Neg (NN.succ (NN.shiftr (NN.pred a) n)) - end. - - Definition shiftr a n := shiftl a (opp n). - - Definition lor a b := - match norm_pos a, norm_pos b with - | Pos a, Pos b => Pos (NN.lor a b) - | Neg a, Pos b => Neg (NN.succ (NN.ldiff (NN.pred a) b)) - | Pos a, Neg b => Neg (NN.succ (NN.ldiff (NN.pred b) a)) - | Neg a, Neg b => Neg (NN.succ (NN.land (NN.pred a) (NN.pred b))) - end. - - Definition land a b := - match norm_pos a, norm_pos b with - | Pos a, Pos b => Pos (NN.land a b) - | Neg a, Pos b => Pos (NN.ldiff b (NN.pred a)) - | Pos a, Neg b => Pos (NN.ldiff a (NN.pred b)) - | Neg a, Neg b => Neg (NN.succ (NN.lor (NN.pred a) (NN.pred b))) - end. - - Definition ldiff a b := - match norm_pos a, norm_pos b with - | Pos a, Pos b => Pos (NN.ldiff a b) - | Neg a, Pos b => Neg (NN.succ (NN.lor (NN.pred a) b)) - | Pos a, Neg b => Pos (NN.land a (NN.pred b)) - | Neg a, Neg b => Pos (NN.ldiff (NN.pred b) (NN.pred a)) - end. - - Definition lxor a b := - match norm_pos a, norm_pos b with - | Pos a, Pos b => Pos (NN.lxor a b) - | Neg a, Pos b => Neg (NN.succ (NN.lxor (NN.pred a) b)) - | Pos a, Neg b => Neg (NN.succ (NN.lxor a (NN.pred b))) - | Neg a, Neg b => Pos (NN.lxor (NN.pred a) (NN.pred b)) - end. - - Definition div2 x := shiftr x one. - - Lemma Zlnot_alt1 : forall x, -(x+1) = Z.lnot x. - Proof. - unfold Z.lnot, Z.pred; auto with zarith. - Qed. - - Lemma Zlnot_alt2 : forall x, Z.lnot (x-1) = -x. - Proof. - unfold Z.lnot, Z.pred; auto with zarith. - Qed. - - Lemma Zlnot_alt3 : forall x, Z.lnot (-x) = x-1. - Proof. - unfold Z.lnot, Z.pred; auto with zarith. - Qed. - - Lemma spec_norm_pos : forall x, to_Z (norm_pos x) = to_Z x. - Proof. - intros [x|x]; simpl; trivial. - rewrite NN.spec_eqb, NN.spec_0. - case Z.eqb_spec; simpl; auto with zarith. - Qed. - - Lemma spec_norm_pos_pos : forall x y, norm_pos x = Neg y -> - 0 < NN.to_Z y. - Proof. - intros [x|x] y; simpl; try easy. - rewrite NN.spec_eqb, NN.spec_0. - case Z.eqb_spec; simpl; try easy. - inversion 2. subst. generalize (NN.spec_pos y); auto with zarith. - Qed. - - Ltac destr_norm_pos x := - rewrite <- (spec_norm_pos x); - let H := fresh in - let x' := fresh x in - assert (H := spec_norm_pos_pos x); - destruct (norm_pos x) as [x'|x']; - specialize (H x' (eq_refl _)) || clear H. - - Lemma spec_testbit: forall x p, testbit x p = Z.testbit (to_Z x) (to_Z p). - Proof. - intros x p. unfold testbit. - destr_norm_pos p; simpl. destr_norm_pos x; simpl. - apply NN.spec_testbit. - rewrite NN.spec_testbit, NN.spec_pred, Z.max_r by auto with zarith. - symmetry. apply Z.bits_opp. apply NN.spec_pos. - symmetry. apply Z.testbit_neg_r; auto with zarith. - Qed. - - Lemma spec_shiftl: forall x p, to_Z (shiftl x p) = Z.shiftl (to_Z x) (to_Z p). - Proof. - intros x p. unfold shiftl. - destr_norm_pos x; destruct p as [p|p]; simpl; - assert (Hp := NN.spec_pos p). - apply NN.spec_shiftl. - rewrite Z.shiftl_opp_r. apply NN.spec_shiftr. - rewrite !NN.spec_shiftl. - rewrite !Z.shiftl_mul_pow2 by apply NN.spec_pos. - symmetry. apply Z.mul_opp_l. - rewrite Z.shiftl_opp_r, NN.spec_succ, NN.spec_shiftr, NN.spec_pred, Z.max_r - by auto with zarith. - now rewrite Zlnot_alt1, Z.lnot_shiftr, Zlnot_alt2. - Qed. - - Lemma spec_shiftr: forall x p, to_Z (shiftr x p) = Z.shiftr (to_Z x) (to_Z p). - Proof. - intros. unfold shiftr. rewrite spec_shiftl, spec_opp. - apply Z.shiftl_opp_r. - Qed. - - Lemma spec_land: forall x y, to_Z (land x y) = Z.land (to_Z x) (to_Z y). - Proof. - intros x y. unfold land. - destr_norm_pos x; destr_norm_pos y; simpl; - rewrite ?NN.spec_succ, ?NN.spec_land, ?NN.spec_ldiff, ?NN.spec_lor, - ?NN.spec_pred, ?Z.max_r, ?Zlnot_alt1; auto with zarith. - now rewrite Z.ldiff_land, Zlnot_alt2. - now rewrite Z.ldiff_land, Z.land_comm, Zlnot_alt2. - now rewrite Z.lnot_lor, !Zlnot_alt2. - Qed. - - Lemma spec_lor: forall x y, to_Z (lor x y) = Z.lor (to_Z x) (to_Z y). - Proof. - intros x y. unfold lor. - destr_norm_pos x; destr_norm_pos y; simpl; - rewrite ?NN.spec_succ, ?NN.spec_land, ?NN.spec_ldiff, ?NN.spec_lor, - ?NN.spec_pred, ?Z.max_r, ?Zlnot_alt1; auto with zarith. - now rewrite Z.lnot_ldiff, Z.lor_comm, Zlnot_alt2. - now rewrite Z.lnot_ldiff, Zlnot_alt2. - now rewrite Z.lnot_land, !Zlnot_alt2. - Qed. - - Lemma spec_ldiff: forall x y, to_Z (ldiff x y) = Z.ldiff (to_Z x) (to_Z y). - Proof. - intros x y. unfold ldiff. - destr_norm_pos x; destr_norm_pos y; simpl; - rewrite ?NN.spec_succ, ?NN.spec_land, ?NN.spec_ldiff, ?NN.spec_lor, - ?NN.spec_pred, ?Z.max_r, ?Zlnot_alt1; auto with zarith. - now rewrite Z.ldiff_land, Zlnot_alt3. - now rewrite Z.lnot_lor, Z.ldiff_land, <- Zlnot_alt2. - now rewrite 2 Z.ldiff_land, Zlnot_alt2, Z.land_comm, Zlnot_alt3. - Qed. - - Lemma spec_lxor: forall x y, to_Z (lxor x y) = Z.lxor (to_Z x) (to_Z y). - Proof. - intros x y. unfold lxor. - destr_norm_pos x; destr_norm_pos y; simpl; - rewrite ?NN.spec_succ, ?NN.spec_lxor, ?NN.spec_pred, ?Z.max_r, ?Zlnot_alt1; - auto with zarith. - now rewrite !Z.lnot_lxor_r, Zlnot_alt2. - now rewrite !Z.lnot_lxor_l, Zlnot_alt2. - now rewrite <- Z.lxor_lnot_lnot, !Zlnot_alt2. - Qed. - - Lemma spec_div2: forall x, to_Z (div2 x) = Z.div2 (to_Z x). - Proof. - intros x. unfold div2. now rewrite spec_shiftr, Z.div2_spec, spec_1. - Qed. - -End Make. diff --git a/theories/Numbers/Integer/SpecViaZ/ZSig.v b/theories/Numbers/Integer/SpecViaZ/ZSig.v deleted file mode 100644 index a360327a48..0000000000 --- a/theories/Numbers/Integer/SpecViaZ/ZSig.v +++ /dev/null @@ -1,135 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) -(* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) -(************************************************************************) - -Require Import BinInt. - -Open Scope Z_scope. - -(** * ZSig *) - -(** Interface of a rich structure about integers. - Specifications are written via translation to Z. -*) - -Module Type ZType. - - Parameter t : Type. - - Parameter to_Z : t -> Z. - Local Notation "[ x ]" := (to_Z x). - - Definition eq x y := [x] = [y]. - Definition lt x y := [x] < [y]. - Definition le x y := [x] <= [y]. - - Parameter of_Z : Z -> t. - Parameter spec_of_Z: forall x, to_Z (of_Z x) = x. - - Parameter compare : t -> t -> comparison. - Parameter eqb : t -> t -> bool. - Parameter ltb : t -> t -> bool. - Parameter leb : t -> t -> bool. - Parameter min : t -> t -> t. - Parameter max : t -> t -> t. - Parameter zero : t. - Parameter one : t. - Parameter two : t. - Parameter minus_one : t. - Parameter succ : t -> t. - Parameter add : t -> t -> t. - Parameter pred : t -> t. - Parameter sub : t -> t -> t. - Parameter opp : t -> t. - Parameter mul : t -> t -> t. - Parameter square : t -> t. - Parameter pow_pos : t -> positive -> t. - Parameter pow_N : t -> N -> t. - Parameter pow : t -> t -> t. - Parameter sqrt : t -> t. - Parameter log2 : t -> t. - Parameter div_eucl : t -> t -> t * t. - Parameter div : t -> t -> t. - Parameter modulo : t -> t -> t. - Parameter quot : t -> t -> t. - Parameter rem : t -> t -> t. - Parameter gcd : t -> t -> t. - Parameter sgn : t -> t. - Parameter abs : t -> t. - Parameter even : t -> bool. - Parameter odd : t -> bool. - Parameter testbit : t -> t -> bool. - Parameter shiftr : t -> t -> t. - Parameter shiftl : t -> t -> t. - Parameter land : t -> t -> t. - Parameter lor : t -> t -> t. - Parameter ldiff : t -> t -> t. - Parameter lxor : t -> t -> t. - Parameter div2 : t -> t. - - Parameter spec_compare: forall x y, compare x y = ([x] ?= [y]). - Parameter spec_eqb : forall x y, eqb x y = ([x] =? [y]). - Parameter spec_ltb : forall x y, ltb x y = ([x] <? [y]). - Parameter spec_leb : forall x y, leb x y = ([x] <=? [y]). - Parameter spec_min : forall x y, [min x y] = Z.min [x] [y]. - Parameter spec_max : forall x y, [max x y] = Z.max [x] [y]. - Parameter spec_0: [zero] = 0. - Parameter spec_1: [one] = 1. - Parameter spec_2: [two] = 2. - Parameter spec_m1: [minus_one] = -1. - Parameter spec_succ: forall n, [succ n] = [n] + 1. - Parameter spec_add: forall x y, [add x y] = [x] + [y]. - Parameter spec_pred: forall x, [pred x] = [x] - 1. - Parameter spec_sub: forall x y, [sub x y] = [x] - [y]. - Parameter spec_opp: forall x, [opp x] = - [x]. - Parameter spec_mul: forall x y, [mul x y] = [x] * [y]. - Parameter spec_square: forall x, [square x] = [x] * [x]. - Parameter spec_pow_pos: forall x n, [pow_pos x n] = [x] ^ Zpos n. - Parameter spec_pow_N: forall x n, [pow_N x n] = [x] ^ Z.of_N n. - Parameter spec_pow: forall x n, [pow x n] = [x] ^ [n]. - Parameter spec_sqrt: forall x, [sqrt x] = Z.sqrt [x]. - Parameter spec_log2: forall x, [log2 x] = Z.log2 [x]. - Parameter spec_div_eucl: forall x y, - let (q,r) := div_eucl x y in ([q], [r]) = Z.div_eucl [x] [y]. - Parameter spec_div: forall x y, [div x y] = [x] / [y]. - Parameter spec_modulo: forall x y, [modulo x y] = [x] mod [y]. - Parameter spec_quot: forall x y, [quot x y] = [x] ÷ [y]. - Parameter spec_rem: forall x y, [rem x y] = Z.rem [x] [y]. - Parameter spec_gcd: forall a b, [gcd a b] = Z.gcd [a] [b]. - Parameter spec_sgn : forall x, [sgn x] = Z.sgn [x]. - Parameter spec_abs : forall x, [abs x] = Z.abs [x]. - Parameter spec_even : forall x, even x = Z.even [x]. - Parameter spec_odd : forall x, odd x = Z.odd [x]. - Parameter spec_testbit: forall x p, testbit x p = Z.testbit [x] [p]. - Parameter spec_shiftr: forall x p, [shiftr x p] = Z.shiftr [x] [p]. - Parameter spec_shiftl: forall x p, [shiftl x p] = Z.shiftl [x] [p]. - Parameter spec_land: forall x y, [land x y] = Z.land [x] [y]. - Parameter spec_lor: forall x y, [lor x y] = Z.lor [x] [y]. - Parameter spec_ldiff: forall x y, [ldiff x y] = Z.ldiff [x] [y]. - Parameter spec_lxor: forall x y, [lxor x y] = Z.lxor [x] [y]. - Parameter spec_div2: forall x, [div2 x] = Z.div2 [x]. - -End ZType. - -Module Type ZType_Notation (Import Z:ZType). - Notation "[ x ]" := (to_Z x). - Infix "==" := eq (at level 70). - Notation "0" := zero. - Notation "1" := one. - Notation "2" := two. - Infix "+" := add. - Infix "-" := sub. - Infix "*" := mul. - Infix "^" := pow. - Notation "- x" := (opp x). - Infix "<=" := le. - Infix "<" := lt. -End ZType_Notation. - -Module Type ZType' := ZType <+ ZType_Notation. diff --git a/theories/Numbers/Integer/SpecViaZ/ZSigZAxioms.v b/theories/Numbers/Integer/SpecViaZ/ZSigZAxioms.v deleted file mode 100644 index 32410d1d0b..0000000000 --- a/theories/Numbers/Integer/SpecViaZ/ZSigZAxioms.v +++ /dev/null @@ -1,527 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -Require Import Bool ZArith OrdersFacts Nnat ZAxioms ZSig. - -(** * The interface [ZSig.ZType] implies the interface [ZAxiomsSig] *) - -Module ZTypeIsZAxioms (Import ZZ : ZType'). - -Hint Rewrite - spec_0 spec_1 spec_2 spec_add spec_sub spec_pred spec_succ - spec_mul spec_opp spec_of_Z spec_div spec_modulo spec_square spec_sqrt - spec_compare spec_eqb spec_ltb spec_leb spec_max spec_min - spec_abs spec_sgn spec_pow spec_log2 spec_even spec_odd spec_gcd - spec_quot spec_rem spec_testbit spec_shiftl spec_shiftr - spec_land spec_lor spec_ldiff spec_lxor spec_div2 - : zsimpl. - -Ltac zsimpl := autorewrite with zsimpl. -Ltac zcongruence := repeat red; intros; zsimpl; congruence. -Ltac zify := unfold eq, lt, le in *; zsimpl. - -Instance eq_equiv : Equivalence eq. -Proof. unfold eq. firstorder. Qed. - -Local Obligation Tactic := zcongruence. - -Program Instance succ_wd : Proper (eq ==> eq) succ. -Program Instance pred_wd : Proper (eq ==> eq) pred. -Program Instance add_wd : Proper (eq ==> eq ==> eq) add. -Program Instance sub_wd : Proper (eq ==> eq ==> eq) sub. -Program Instance mul_wd : Proper (eq ==> eq ==> eq) mul. - -Theorem pred_succ : forall n, pred (succ n) == n. -Proof. -intros. zify. auto with zarith. -Qed. - -Theorem one_succ : 1 == succ 0. -Proof. -now zify. -Qed. - -Theorem two_succ : 2 == succ 1. -Proof. -now zify. -Qed. - -Section Induction. - -Variable A : ZZ.t -> Prop. -Hypothesis A_wd : Proper (eq==>iff) A. -Hypothesis A0 : A 0. -Hypothesis AS : forall n, A n <-> A (succ n). - -Let B (z : Z) := A (of_Z z). - -Lemma B0 : B 0. -Proof. -unfold B; simpl. -rewrite <- (A_wd 0); auto. -zify. auto. -Qed. - -Lemma BS : forall z : Z, B z -> B (z + 1). -Proof. -intros z H. -unfold B in *. apply -> AS in H. -setoid_replace (of_Z (z + 1)) with (succ (of_Z z)); auto. -zify. auto. -Qed. - -Lemma BP : forall z : Z, B z -> B (z - 1). -Proof. -intros z H. -unfold B in *. rewrite AS. -setoid_replace (succ (of_Z (z - 1))) with (of_Z z); auto. -zify. auto with zarith. -Qed. - -Lemma B_holds : forall z : Z, B z. -Proof. -intros; destruct (Z_lt_le_dec 0 z). -apply natlike_ind; auto with zarith. -apply B0. -intros; apply BS; auto. -replace z with (-(-z))%Z in * by (auto with zarith). -remember (-z)%Z as z'. -pattern z'; apply natlike_ind. -apply B0. -intros; rewrite Z.opp_succ; unfold Z.pred; apply BP; auto. -subst z'; auto with zarith. -Qed. - -Theorem bi_induction : forall n, A n. -Proof. -intro n. setoid_replace n with (of_Z (to_Z n)). -apply B_holds. -zify. auto. -Qed. - -End Induction. - -Theorem add_0_l : forall n, 0 + n == n. -Proof. -intros. zify. auto with zarith. -Qed. - -Theorem add_succ_l : forall n m, (succ n) + m == succ (n + m). -Proof. -intros. zify. auto with zarith. -Qed. - -Theorem sub_0_r : forall n, n - 0 == n. -Proof. -intros. zify. auto with zarith. -Qed. - -Theorem sub_succ_r : forall n m, n - (succ m) == pred (n - m). -Proof. -intros. zify. auto with zarith. -Qed. - -Theorem mul_0_l : forall n, 0 * n == 0. -Proof. -intros. zify. auto with zarith. -Qed. - -Theorem mul_succ_l : forall n m, (succ n) * m == n * m + m. -Proof. -intros. zify. ring. -Qed. - -(** Order *) - -Lemma eqb_eq x y : eqb x y = true <-> x == y. -Proof. - zify. apply Z.eqb_eq. -Qed. - -Lemma leb_le x y : leb x y = true <-> x <= y. -Proof. - zify. apply Z.leb_le. -Qed. - -Lemma ltb_lt x y : ltb x y = true <-> x < y. -Proof. - zify. apply Z.ltb_lt. -Qed. - -Lemma compare_eq_iff n m : compare n m = Eq <-> n == m. -Proof. - intros. zify. apply Z.compare_eq_iff. -Qed. - -Lemma compare_lt_iff n m : compare n m = Lt <-> n < m. -Proof. - intros. zify. reflexivity. -Qed. - -Lemma compare_le_iff n m : compare n m <> Gt <-> n <= m. -Proof. - intros. zify. reflexivity. -Qed. - -Lemma compare_antisym n m : compare m n = CompOpp (compare n m). -Proof. - intros. zify. apply Z.compare_antisym. -Qed. - -Include BoolOrderFacts ZZ ZZ ZZ [no inline]. - -Instance compare_wd : Proper (eq ==> eq ==> Logic.eq) compare. -Proof. -intros x x' Hx y y' Hy. zify. now rewrite Hx, Hy. -Qed. - -Instance eqb_wd : Proper (eq ==> eq ==> Logic.eq) eqb. -Proof. -intros x x' Hx y y' Hy. zify. now rewrite Hx, Hy. -Qed. - -Instance ltb_wd : Proper (eq ==> eq ==> Logic.eq) ltb. -Proof. -intros x x' Hx y y' Hy. zify. now rewrite Hx, Hy. -Qed. - -Instance leb_wd : Proper (eq ==> eq ==> Logic.eq) leb. -Proof. -intros x x' Hx y y' Hy. zify. now rewrite Hx, Hy. -Qed. - -Instance lt_wd : Proper (eq ==> eq ==> iff) lt. -Proof. -intros x x' Hx y y' Hy; unfold lt; rewrite Hx, Hy; intuition. -Qed. - -Theorem lt_succ_r : forall n m, n < (succ m) <-> n <= m. -Proof. -intros. zify. omega. -Qed. - -Theorem min_l : forall n m, n <= m -> min n m == n. -Proof. -intros n m. zify. omega with *. -Qed. - -Theorem min_r : forall n m, m <= n -> min n m == m. -Proof. -intros n m. zify. omega with *. -Qed. - -Theorem max_l : forall n m, m <= n -> max n m == n. -Proof. -intros n m. zify. omega with *. -Qed. - -Theorem max_r : forall n m, n <= m -> max n m == m. -Proof. -intros n m. zify. omega with *. -Qed. - -(** Part specific to integers, not natural numbers *) - -Theorem succ_pred : forall n, succ (pred n) == n. -Proof. -intros. zify. auto with zarith. -Qed. - -(** Opp *) - -Program Instance opp_wd : Proper (eq ==> eq) opp. - -Theorem opp_0 : - 0 == 0. -Proof. -intros. zify. auto with zarith. -Qed. - -Theorem opp_succ : forall n, - (succ n) == pred (- n). -Proof. -intros. zify. auto with zarith. -Qed. - -(** Abs / Sgn *) - -Theorem abs_eq : forall n, 0 <= n -> abs n == n. -Proof. -intros n. zify. omega with *. -Qed. - -Theorem abs_neq : forall n, n <= 0 -> abs n == -n. -Proof. -intros n. zify. omega with *. -Qed. - -Theorem sgn_null : forall n, n==0 -> sgn n == 0. -Proof. -intros n. zify. omega with *. -Qed. - -Theorem sgn_pos : forall n, 0<n -> sgn n == 1. -Proof. -intros n. zify. omega with *. -Qed. - -Theorem sgn_neg : forall n, n<0 -> sgn n == opp 1. -Proof. -intros n. zify. omega with *. -Qed. - -(** Power *) - -Program Instance pow_wd : Proper (eq==>eq==>eq) pow. - -Lemma pow_0_r : forall a, a^0 == 1. -Proof. - intros. now zify. -Qed. - -Lemma pow_succ_r : forall a b, 0<=b -> a^(succ b) == a * a^b. -Proof. - intros a b. zify. intros. now rewrite Z.add_1_r, Z.pow_succ_r. -Qed. - -Lemma pow_neg_r : forall a b, b<0 -> a^b == 0. -Proof. - intros a b. zify. intros Hb. - destruct [b]; reflexivity || discriminate. -Qed. - -Lemma pow_pow_N : forall a b, 0<=b -> a^b == pow_N a (Z.to_N (to_Z b)). -Proof. - intros a b. zify. intros Hb. now rewrite spec_pow_N, Z2N.id. -Qed. - -Lemma pow_pos_N : forall a p, pow_pos a p == pow_N a (Npos p). -Proof. - intros a b. red. now rewrite spec_pow_N, spec_pow_pos. -Qed. - -(** Square *) - -Lemma square_spec n : square n == n * n. -Proof. - now zify. -Qed. - -(** Sqrt *) - -Lemma sqrt_spec : forall n, 0<=n -> - (sqrt n)*(sqrt n) <= n /\ n < (succ (sqrt n))*(succ (sqrt n)). -Proof. - intros n. zify. apply Z.sqrt_spec. -Qed. - -Lemma sqrt_neg : forall n, n<0 -> sqrt n == 0. -Proof. - intros n. zify. apply Z.sqrt_neg. -Qed. - -(** Log2 *) - -Lemma log2_spec : forall n, 0<n -> - 2^(log2 n) <= n /\ n < 2^(succ (log2 n)). -Proof. - intros n. zify. apply Z.log2_spec. -Qed. - -Lemma log2_nonpos : forall n, n<=0 -> log2 n == 0. -Proof. - intros n. zify. apply Z.log2_nonpos. -Qed. - -(** Even / Odd *) - -Definition Even n := exists m, n == 2*m. -Definition Odd n := exists m, n == 2*m+1. - -Lemma even_spec n : even n = true <-> Even n. -Proof. - unfold Even. zify. rewrite Z.even_spec. - split; intros (m,Hm). - - exists (of_Z m). now zify. - - exists [m]. revert Hm. now zify. -Qed. - -Lemma odd_spec n : odd n = true <-> Odd n. -Proof. - unfold Odd. zify. rewrite Z.odd_spec. - split; intros (m,Hm). - - exists (of_Z m). now zify. - - exists [m]. revert Hm. now zify. -Qed. - -(** Div / Mod *) - -Program Instance div_wd : Proper (eq==>eq==>eq) div. -Program Instance mod_wd : Proper (eq==>eq==>eq) modulo. - -Theorem div_mod : forall a b, ~b==0 -> a == b*(div a b) + (modulo a b). -Proof. -intros a b. zify. intros. apply Z.div_mod; auto. -Qed. - -Theorem mod_pos_bound : - forall a b, 0 < b -> 0 <= modulo a b /\ modulo a b < b. -Proof. -intros a b. zify. intros. apply Z_mod_lt; auto with zarith. -Qed. - -Theorem mod_neg_bound : - forall a b, b < 0 -> b < modulo a b /\ modulo a b <= 0. -Proof. -intros a b. zify. intros. apply Z_mod_neg; auto with zarith. -Qed. - -Definition mod_bound_pos : - forall a b, 0<=a -> 0<b -> 0 <= modulo a b /\ modulo a b < b := - fun a b _ H => mod_pos_bound a b H. - -(** Quot / Rem *) - -Program Instance quot_wd : Proper (eq==>eq==>eq) quot. -Program Instance rem_wd : Proper (eq==>eq==>eq) rem. - -Theorem quot_rem : forall a b, ~b==0 -> a == b*(quot a b) + rem a b. -Proof. -intros a b. zify. apply Z.quot_rem. -Qed. - -Theorem rem_bound_pos : - forall a b, 0<=a -> 0<b -> 0 <= rem a b /\ rem a b < b. -Proof. -intros a b. zify. apply Z.rem_bound_pos. -Qed. - -Theorem rem_opp_l : forall a b, ~b==0 -> rem (-a) b == -(rem a b). -Proof. -intros a b. zify. apply Z.rem_opp_l. -Qed. - -Theorem rem_opp_r : forall a b, ~b==0 -> rem a (-b) == rem a b. -Proof. -intros a b. zify. apply Z.rem_opp_r. -Qed. - -(** Gcd *) - -Definition divide n m := exists p, m == p*n. -Local Notation "( x | y )" := (divide x y) (at level 0). - -Lemma spec_divide : forall n m, (n|m) <-> Z.divide [n] [m]. -Proof. - intros n m. split. - - intros (p,H). exists [p]. revert H; now zify. - - intros (z,H). exists (of_Z z). now zify. -Qed. - -Lemma gcd_divide_l : forall n m, (gcd n m | n). -Proof. - intros n m. apply spec_divide. zify. apply Z.gcd_divide_l. -Qed. - -Lemma gcd_divide_r : forall n m, (gcd n m | m). -Proof. - intros n m. apply spec_divide. zify. apply Z.gcd_divide_r. -Qed. - -Lemma gcd_greatest : forall n m p, (p|n) -> (p|m) -> (p|gcd n m). -Proof. - intros n m p. rewrite !spec_divide. zify. apply Z.gcd_greatest. -Qed. - -Lemma gcd_nonneg : forall n m, 0 <= gcd n m. -Proof. - intros. zify. apply Z.gcd_nonneg. -Qed. - -(** Bitwise operations *) - -Program Instance testbit_wd : Proper (eq==>eq==>Logic.eq) testbit. - -Lemma testbit_odd_0 : forall a, testbit (2*a+1) 0 = true. -Proof. - intros. zify. apply Z.testbit_odd_0. -Qed. - -Lemma testbit_even_0 : forall a, testbit (2*a) 0 = false. -Proof. - intros. zify. apply Z.testbit_even_0. -Qed. - -Lemma testbit_odd_succ : forall a n, 0<=n -> - testbit (2*a+1) (succ n) = testbit a n. -Proof. - intros a n. zify. apply Z.testbit_odd_succ. -Qed. - -Lemma testbit_even_succ : forall a n, 0<=n -> - testbit (2*a) (succ n) = testbit a n. -Proof. - intros a n. zify. apply Z.testbit_even_succ. -Qed. - -Lemma testbit_neg_r : forall a n, n<0 -> testbit a n = false. -Proof. - intros a n. zify. apply Z.testbit_neg_r. -Qed. - -Lemma shiftr_spec : forall a n m, 0<=m -> - testbit (shiftr a n) m = testbit a (m+n). -Proof. - intros a n m. zify. apply Z.shiftr_spec. -Qed. - -Lemma shiftl_spec_high : forall a n m, 0<=m -> n<=m -> - testbit (shiftl a n) m = testbit a (m-n). -Proof. - intros a n m. zify. intros Hn H. - now apply Z.shiftl_spec_high. -Qed. - -Lemma shiftl_spec_low : forall a n m, m<n -> - testbit (shiftl a n) m = false. -Proof. - intros a n m. zify. intros H. now apply Z.shiftl_spec_low. -Qed. - -Lemma land_spec : forall a b n, - testbit (land a b) n = testbit a n && testbit b n. -Proof. - intros a n m. zify. now apply Z.land_spec. -Qed. - -Lemma lor_spec : forall a b n, - testbit (lor a b) n = testbit a n || testbit b n. -Proof. - intros a n m. zify. now apply Z.lor_spec. -Qed. - -Lemma ldiff_spec : forall a b n, - testbit (ldiff a b) n = testbit a n && negb (testbit b n). -Proof. - intros a n m. zify. now apply Z.ldiff_spec. -Qed. - -Lemma lxor_spec : forall a b n, - testbit (lxor a b) n = xorb (testbit a n) (testbit b n). -Proof. - intros a n m. zify. now apply Z.lxor_spec. -Qed. - -Lemma div2_spec : forall a, div2 a == shiftr a 1. -Proof. - intros a. zify. now apply Z.div2_spec. -Qed. - -End ZTypeIsZAxioms. - -Module ZType_ZAxioms (ZZ : ZType) - <: ZAxiomsSig <: OrderFunctions ZZ <: HasMinMax ZZ - := ZZ <+ ZTypeIsZAxioms. diff --git a/theories/Numbers/Natural/BigN/BigN.v b/theories/Numbers/Natural/BigN/BigN.v deleted file mode 100644 index e8ff516f35..0000000000 --- a/theories/Numbers/Natural/BigN/BigN.v +++ /dev/null @@ -1,198 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(** * Efficient arbitrary large natural numbers in base 2^31 *) - -(** Initial Author: Arnaud Spiwack *) - -Require Export Int31. -Require Import CyclicAxioms Cyclic31 Ring31 NSig NSigNAxioms NMake - NProperties GenericMinMax. - -(** The following [BigN] module regroups both the operations and - all the abstract properties: - - - [NMake.Make Int31Cyclic] provides the operations and basic specs - w.r.t. ZArith - - [NTypeIsNAxioms] shows (mainly) that these operations implement - the interface [NAxioms] - - [NProp] adds all generic properties derived from [NAxioms] - - [MinMax*Properties] provides properties of [min] and [max]. - -*) - -Delimit Scope bigN_scope with bigN. - -Module BigN <: NType <: OrderedTypeFull <: TotalOrder := - NMake.Make Int31Cyclic - <+ NTypeIsNAxioms - <+ NBasicProp [no inline] <+ NExtraProp [no inline] - <+ HasEqBool2Dec [no inline] - <+ MinMaxLogicalProperties [no inline] - <+ MinMaxDecProperties [no inline]. - -(** Notations about [BigN] *) - -Local Open Scope bigN_scope. - -Notation bigN := BigN.t. -Bind Scope bigN_scope with bigN BigN.t BigN.t'. -Arguments BigN.N0 _%int31. -Local Notation "0" := BigN.zero : bigN_scope. (* temporary notation *) -Local Notation "1" := BigN.one : bigN_scope. (* temporary notation *) -Local Notation "2" := BigN.two : bigN_scope. (* temporary notation *) -Infix "+" := BigN.add : bigN_scope. -Infix "-" := BigN.sub : bigN_scope. -Infix "*" := BigN.mul : bigN_scope. -Infix "/" := BigN.div : bigN_scope. -Infix "^" := BigN.pow : bigN_scope. -Infix "?=" := BigN.compare : bigN_scope. -Infix "=?" := BigN.eqb (at level 70, no associativity) : bigN_scope. -Infix "<=?" := BigN.leb (at level 70, no associativity) : bigN_scope. -Infix "<?" := BigN.ltb (at level 70, no associativity) : bigN_scope. -Infix "==" := BigN.eq (at level 70, no associativity) : bigN_scope. -Notation "x != y" := (~x==y) (at level 70, no associativity) : bigN_scope. -Infix "<" := BigN.lt : bigN_scope. -Infix "<=" := BigN.le : bigN_scope. -Notation "x > y" := (y < x) (only parsing) : bigN_scope. -Notation "x >= y" := (y <= x) (only parsing) : bigN_scope. -Notation "x < y < z" := (x<y /\ y<z) : bigN_scope. -Notation "x < y <= z" := (x<y /\ y<=z) : bigN_scope. -Notation "x <= y < z" := (x<=y /\ y<z) : bigN_scope. -Notation "x <= y <= z" := (x<=y /\ y<=z) : bigN_scope. -Notation "[ i ]" := (BigN.to_Z i) : bigN_scope. -Infix "mod" := BigN.modulo (at level 40, no associativity) : bigN_scope. - -(** Example of reasoning about [BigN] *) - -Theorem succ_pred: forall q : bigN, - 0 < q -> BigN.succ (BigN.pred q) == q. -Proof. -intros; apply BigN.succ_pred. -intro H'; rewrite H' in H; discriminate. -Qed. - -(** [BigN] is a semi-ring *) - -Lemma BigNring : semi_ring_theory 0 1 BigN.add BigN.mul BigN.eq. -Proof. -constructor. -exact BigN.add_0_l. exact BigN.add_comm. exact BigN.add_assoc. -exact BigN.mul_1_l. exact BigN.mul_0_l. exact BigN.mul_comm. -exact BigN.mul_assoc. exact BigN.mul_add_distr_r. -Qed. - -Lemma BigNeqb_correct : forall x y, (x =? y) = true -> x==y. -Proof. now apply BigN.eqb_eq. Qed. - -Lemma BigNpower : power_theory 1 BigN.mul BigN.eq BigN.of_N BigN.pow. -Proof. -constructor. -intros. red. rewrite BigN.spec_pow, BigN.spec_of_N. -rewrite Zpower_theory.(rpow_pow_N). -destruct n; simpl. reflexivity. -induction p; simpl; intros; BigN.zify; rewrite ?IHp; auto. -Qed. - -Lemma BigNdiv : div_theory BigN.eq BigN.add BigN.mul (@id _) - (fun a b => if b =? 0 then (0,a) else BigN.div_eucl a b). -Proof. -constructor. unfold id. intros a b. -BigN.zify. -case Z.eqb_spec. -BigN.zify. auto with zarith. -intros NEQ. -generalize (BigN.spec_div_eucl a b). -generalize (Z_div_mod_full [a] [b] NEQ). -destruct BigN.div_eucl as (q,r), Z.div_eucl as (q',r'). -intros (EQ,_). injection 1 as EQr EQq. -BigN.zify. rewrite EQr, EQq; auto. -Qed. - - -(** Detection of constants *) - -Ltac isStaticWordCst t := - match t with - | W0 => constr:(true) - | WW ?t1 ?t2 => - match isStaticWordCst t1 with - | false => constr:(false) - | true => isStaticWordCst t2 - end - | _ => isInt31cst t - end. - -Ltac isBigNcst t := - match t with - | BigN.N0 ?t => isStaticWordCst t - | BigN.N1 ?t => isStaticWordCst t - | BigN.N2 ?t => isStaticWordCst t - | BigN.N3 ?t => isStaticWordCst t - | BigN.N4 ?t => isStaticWordCst t - | BigN.N5 ?t => isStaticWordCst t - | BigN.N6 ?t => isStaticWordCst t - | BigN.Nn ?n ?t => match isnatcst n with - | true => isStaticWordCst t - | false => constr:(false) - end - | BigN.zero => constr:(true) - | BigN.one => constr:(true) - | BigN.two => constr:(true) - | _ => constr:(false) - end. - -Ltac BigNcst t := - match isBigNcst t with - | true => constr:(t) - | false => constr:(NotConstant) - end. - -Ltac BigN_to_N t := - match isBigNcst t with - | true => eval vm_compute in (BigN.to_N t) - | false => constr:(NotConstant) - end. - -Ltac Ncst t := - match isNcst t with - | true => constr:(t) - | false => constr:(NotConstant) - end. - -(** Registration for the "ring" tactic *) - -Add Ring BigNr : BigNring - (decidable BigNeqb_correct, - constants [BigNcst], - power_tac BigNpower [BigN_to_N], - div BigNdiv). - -Section TestRing. -Let test : forall x y, 1 + x*y^1 + x^2 + 1 == 1*1 + 1 + y*x + 1*x*x. -intros. ring_simplify. reflexivity. -Qed. -End TestRing. - -(** We benefit also from an "order" tactic *) - -Ltac bigN_order := BigN.order. - -Section TestOrder. -Let test : forall x y : bigN, x<=y -> y<=x -> x==y. -Proof. bigN_order. Qed. -End TestOrder. - -(** We can use at least a bit of (r)omega by translating to [Z]. *) - -Section TestOmega. -Let test : forall x y : bigN, x<=y -> y<=x -> x==y. -Proof. intros x y. BigN.zify. omega. Qed. -End TestOmega. - -(** Todo: micromega *) diff --git a/theories/Numbers/Natural/BigN/NMake.v b/theories/Numbers/Natural/BigN/NMake.v deleted file mode 100644 index 1425041a10..0000000000 --- a/theories/Numbers/Natural/BigN/NMake.v +++ /dev/null @@ -1,1706 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) -(* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) -(************************************************************************) - -(** * NMake *) - -(** From a cyclic Z/nZ representation to arbitrary precision natural numbers.*) - -(** NB: This file contain the part which is independent from the underlying - representation. The representation-dependent (and macro-generated) part - is now in [NMake_gen]. *) - -Require Import Bool BigNumPrelude ZArith Nnat Ndigits CyclicAxioms DoubleType - Nbasic Wf_nat StreamMemo NSig NMake_gen. - -Module Make (W0:CyclicType) <: NType. - - (** Let's include the macro-generated part. Even if we can't functorize - things (due to Eval red_t below), the rest of the module only uses - elements mentionned in interface [NAbstract]. *) - - Include NMake_gen.Make W0. - - Open Scope Z_scope. - - Local Notation "[ x ]" := (to_Z x). - - Definition eq (x y : t) := [x] = [y]. - - Declare Reduction red_t := - lazy beta iota delta - [iter_t reduce same_level mk_t mk_t_S succ_t dom_t dom_op]. - - Ltac red_t := - match goal with |- ?u => let v := (eval red_t in u) in change v end. - - (** * Generic results *) - - Tactic Notation "destr_t" constr(x) "as" simple_intropattern(pat) := - destruct (destr_t x) as pat; cbv zeta; - rewrite ?iter_mk_t, ?spec_mk_t, ?spec_reduce. - - Lemma spec_same_level : forall A (P:Z->Z->A->Prop) - (f : forall n, dom_t n -> dom_t n -> A), - (forall n x y, P (ZnZ.to_Z x) (ZnZ.to_Z y) (f n x y)) -> - forall x y, P [x] [y] (same_level f x y). - Proof. - intros. apply spec_same_level_dep with (P:=fun _ => P); auto. - Qed. - - Theorem spec_pos: forall x, 0 <= [x]. - Proof. - intros x. destr_t x as (n,x). now case (ZnZ.spec_to_Z x). - Qed. - - Lemma digits_dom_op_incr : forall n m, (n<=m)%nat -> - (ZnZ.digits (dom_op n) <= ZnZ.digits (dom_op m))%positive. - Proof. - intros. - change (Zpos (ZnZ.digits (dom_op n)) <= Zpos (ZnZ.digits (dom_op m))). - rewrite !digits_dom_op, !Pshiftl_nat_Zpower. - apply Z.mul_le_mono_nonneg_l; auto with zarith. - apply Z.pow_le_mono_r; auto with zarith. - Qed. - - Definition to_N (x : t) := Z.to_N (to_Z x). - - (** * Zero, One *) - - Definition zero := mk_t O ZnZ.zero. - Definition one := mk_t O ZnZ.one. - - Theorem spec_0: [zero] = 0. - Proof. - unfold zero. rewrite spec_mk_t. exact ZnZ.spec_0. - Qed. - - Theorem spec_1: [one] = 1. - Proof. - unfold one. rewrite spec_mk_t. exact ZnZ.spec_1. - Qed. - - (** * Successor *) - - (** NB: it is crucial here and for the rest of this file to preserve - the let-in's. They allow to pre-compute once and for all the - field access to Z/nZ initial structures (when n=0..6). *) - - Local Notation succn := (fun n => - let op := dom_op n in - let succ_c := ZnZ.succ_c in - let one := ZnZ.one in - fun x => match succ_c x with - | C0 r => mk_t n r - | C1 r => mk_t_S n (WW one r) - end). - - Definition succ : t -> t := Eval red_t in iter_t succn. - - Lemma succ_fold : succ = iter_t succn. - Proof. red_t; reflexivity. Qed. - - Theorem spec_succ: forall n, [succ n] = [n] + 1. - Proof. - intros x. rewrite succ_fold. destr_t x as (n,x). - generalize (ZnZ.spec_succ_c x); case ZnZ.succ_c. - intros. rewrite spec_mk_t. assumption. - intros. unfold interp_carry in *. - rewrite spec_mk_t_S. simpl. rewrite ZnZ.spec_1. assumption. - Qed. - - (** Two *) - - (** Not really pretty, but since W0 might be Z/2Z, we're not sure - there's a proper 2 there. *) - - Definition two := succ one. - - Lemma spec_2 : [two] = 2. - Proof. - unfold two. now rewrite spec_succ, spec_1. - Qed. - - (** * Addition *) - - Local Notation addn := (fun n => - let op := dom_op n in - let add_c := ZnZ.add_c in - let one := ZnZ.one in - fun x y =>match add_c x y with - | C0 r => mk_t n r - | C1 r => mk_t_S n (WW one r) - end). - - Definition add : t -> t -> t := Eval red_t in same_level addn. - - Lemma add_fold : add = same_level addn. - Proof. red_t; reflexivity. Qed. - - Theorem spec_add: forall x y, [add x y] = [x] + [y]. - Proof. - intros x y. rewrite add_fold. apply spec_same_level; clear x y. - intros n x y. cbv beta iota zeta. - generalize (ZnZ.spec_add_c x y); case ZnZ.add_c; intros z H. - rewrite spec_mk_t. assumption. - rewrite spec_mk_t_S. unfold interp_carry in H. - simpl. rewrite ZnZ.spec_1. assumption. - Qed. - - (** * Predecessor *) - - Local Notation predn := (fun n => - let pred_c := ZnZ.pred_c in - fun x => match pred_c x with - | C0 r => reduce n r - | C1 _ => zero - end). - - Definition pred : t -> t := Eval red_t in iter_t predn. - - Lemma pred_fold : pred = iter_t predn. - Proof. red_t; reflexivity. Qed. - - Theorem spec_pred_pos : forall x, 0 < [x] -> [pred x] = [x] - 1. - Proof. - intros x. rewrite pred_fold. destr_t x as (n,x). intros H. - generalize (ZnZ.spec_pred_c x); case ZnZ.pred_c; intros y H'. - rewrite spec_reduce. assumption. - exfalso. unfold interp_carry in *. - generalize (ZnZ.spec_to_Z x) (ZnZ.spec_to_Z y); auto with zarith. - Qed. - - Theorem spec_pred0 : forall x, [x] = 0 -> [pred x] = 0. - Proof. - intros x. rewrite pred_fold. destr_t x as (n,x). intros H. - generalize (ZnZ.spec_pred_c x); case ZnZ.pred_c; intros y H'. - rewrite spec_reduce. - unfold interp_carry in H'. - generalize (ZnZ.spec_to_Z y); auto with zarith. - exact spec_0. - Qed. - - Lemma spec_pred x : [pred x] = Z.max 0 ([x]-1). - Proof. - rewrite Z.max_comm. - destruct (Z.max_spec ([x]-1) 0) as [(H,->)|(H,->)]. - - apply spec_pred0; generalize (spec_pos x); auto with zarith. - - apply spec_pred_pos; auto with zarith. - Qed. - - (** * Subtraction *) - - Local Notation subn := (fun n => - let sub_c := ZnZ.sub_c in - fun x y => match sub_c x y with - | C0 r => reduce n r - | C1 r => zero - end). - - Definition sub : t -> t -> t := Eval red_t in same_level subn. - - Lemma sub_fold : sub = same_level subn. - Proof. red_t; reflexivity. Qed. - - Theorem spec_sub_pos : forall x y, [y] <= [x] -> [sub x y] = [x] - [y]. - Proof. - intros x y. rewrite sub_fold. apply spec_same_level. clear x y. - intros n x y. simpl. - generalize (ZnZ.spec_sub_c x y); case ZnZ.sub_c; intros z H LE. - rewrite spec_reduce. assumption. - unfold interp_carry in H. - exfalso. - generalize (ZnZ.spec_to_Z z); auto with zarith. - Qed. - - Theorem spec_sub0 : forall x y, [x] < [y] -> [sub x y] = 0. - Proof. - intros x y. rewrite sub_fold. apply spec_same_level. clear x y. - intros n x y. simpl. - generalize (ZnZ.spec_sub_c x y); case ZnZ.sub_c; intros z H LE. - rewrite spec_reduce. - unfold interp_carry in H. - generalize (ZnZ.spec_to_Z z); auto with zarith. - exact spec_0. - Qed. - - Lemma spec_sub : forall x y, [sub x y] = Z.max 0 ([x]-[y]). - Proof. - intros. destruct (Z.le_gt_cases [y] [x]). - rewrite Z.max_r; auto with zarith. apply spec_sub_pos; auto. - rewrite Z.max_l; auto with zarith. apply spec_sub0; auto. - Qed. - - (** * Comparison *) - - Definition comparen_m n : - forall m, word (dom_t n) (S m) -> dom_t n -> comparison := - let op := dom_op n in - let zero := ZnZ.zero (Ops:=op) in - let compare := ZnZ.compare (Ops:=op) in - let compare0 := compare zero in - fun m => compare_mn_1 (dom_t n) (dom_t n) zero compare compare0 compare (S m). - - Let spec_comparen_m: - forall n m (x : word (dom_t n) (S m)) (y : dom_t n), - comparen_m n m x y = Z.compare (eval n (S m) x) (ZnZ.to_Z y). - Proof. - intros n m x y. - unfold comparen_m, eval. - rewrite nmake_double. - apply spec_compare_mn_1. - exact ZnZ.spec_0. - intros. apply ZnZ.spec_compare. - exact ZnZ.spec_to_Z. - exact ZnZ.spec_compare. - exact ZnZ.spec_compare. - exact ZnZ.spec_to_Z. - Qed. - - Definition comparenm n m wx wy := - let mn := Max.max n m in - let d := diff n m in - let op := make_op mn in - ZnZ.compare - (castm (diff_r n m) (extend_tr wx (snd d))) - (castm (diff_l n m) (extend_tr wy (fst d))). - - Local Notation compare_folded := - (iter_sym _ - (fun n => ZnZ.compare (Ops:=dom_op n)) - comparen_m - comparenm - CompOpp). - - Definition compare : t -> t -> comparison := - Eval lazy beta iota delta [iter_sym dom_op dom_t comparen_m] in - compare_folded. - - Lemma compare_fold : compare = compare_folded. - Proof. - lazy beta iota delta [iter_sym dom_op dom_t comparen_m]. reflexivity. - Qed. - - Theorem spec_compare : forall x y, - compare x y = Z.compare [x] [y]. - Proof. - intros x y. rewrite compare_fold. apply spec_iter_sym; clear x y. - intros. apply ZnZ.spec_compare. - intros. cbv beta zeta. apply spec_comparen_m. - intros n m x y; unfold comparenm. - rewrite (spec_cast_l n m x), (spec_cast_r n m y). - unfold to_Z; apply ZnZ.spec_compare. - intros. subst. now rewrite <- Z.compare_antisym. - Qed. - - Definition eqb (x y : t) : bool := - match compare x y with - | Eq => true - | _ => false - end. - - Theorem spec_eqb x y : eqb x y = Z.eqb [x] [y]. - Proof. - apply eq_iff_eq_true. - unfold eqb. rewrite Z.eqb_eq, <- Z.compare_eq_iff, spec_compare. - split; [now destruct Z.compare | now intros ->]. - Qed. - - Definition lt (n m : t) := [n] < [m]. - Definition le (n m : t) := [n] <= [m]. - - Definition ltb (x y : t) : bool := - match compare x y with - | Lt => true - | _ => false - end. - - Theorem spec_ltb x y : ltb x y = Z.ltb [x] [y]. - Proof. - apply eq_iff_eq_true. - rewrite Z.ltb_lt. unfold Z.lt, ltb. rewrite spec_compare. - split; [now destruct Z.compare | now intros ->]. - Qed. - - Definition leb (x y : t) : bool := - match compare x y with - | Gt => false - | _ => true - end. - - Theorem spec_leb x y : leb x y = Z.leb [x] [y]. - Proof. - apply eq_iff_eq_true. - rewrite Z.leb_le. unfold Z.le, leb. rewrite spec_compare. - now destruct Z.compare; split. - Qed. - - Definition min (n m : t) : t := match compare n m with Gt => m | _ => n end. - Definition max (n m : t) : t := match compare n m with Lt => m | _ => n end. - - Theorem spec_max : forall n m, [max n m] = Z.max [n] [m]. - Proof. - intros. unfold max, Z.max. rewrite spec_compare; destruct Z.compare; reflexivity. - Qed. - - Theorem spec_min : forall n m, [min n m] = Z.min [n] [m]. - Proof. - intros. unfold min, Z.min. rewrite spec_compare; destruct Z.compare; reflexivity. - Qed. - - (** * Multiplication *) - - Definition wn_mul n : forall m, word (dom_t n) (S m) -> dom_t n -> t := - let op := dom_op n in - let zero := ZnZ.zero in - let succ := ZnZ.succ (Ops:=op) in - let add_c := ZnZ.add_c (Ops:=op) in - let mul_c := ZnZ.mul_c (Ops:=op) in - let ww := @ZnZ.WW _ op in - let ow := @ZnZ.OW _ op in - let eq0 := ZnZ.eq0 in - let mul_add := @DoubleMul.w_mul_add _ zero succ add_c mul_c in - let mul_add_n1 := @DoubleMul.double_mul_add_n1 _ zero ww ow mul_add in - fun m x y => - let (w,r) := mul_add_n1 (S m) x y zero in - if eq0 w then mk_t_w' n m r - else mk_t_w' n (S m) (WW (extend n m w) r). - - Definition mulnm n m x y := - let mn := Max.max n m in - let d := diff n m in - let op := make_op mn in - reduce_n (S mn) (ZnZ.mul_c - (castm (diff_r n m) (extend_tr x (snd d))) - (castm (diff_l n m) (extend_tr y (fst d)))). - - Local Notation mul_folded := - (iter_sym _ - (fun n => let mul_c := ZnZ.mul_c in - fun x y => reduce (S n) (succ_t _ (mul_c x y))) - wn_mul - mulnm - (fun x => x)). - - Definition mul : t -> t -> t := - Eval lazy beta iota delta - [iter_sym dom_op dom_t reduce succ_t extend zeron - wn_mul DoubleMul.w_mul_add mk_t_w'] in - mul_folded. - - Lemma mul_fold : mul = mul_folded. - Proof. - lazy beta iota delta - [iter_sym dom_op dom_t reduce succ_t extend zeron - wn_mul DoubleMul.w_mul_add mk_t_w']. reflexivity. - Qed. - - Lemma spec_muln: - forall n (x: word _ (S n)) y, - [Nn (S n) (ZnZ.mul_c (Ops:=make_op n) x y)] = [Nn n x] * [Nn n y]. - Proof. - intros n x y; unfold to_Z. - rewrite <- ZnZ.spec_mul_c. - rewrite make_op_S. - case ZnZ.mul_c; auto. - Qed. - - Lemma spec_mul_add_n1: forall n m x y z, - let (q,r) := DoubleMul.double_mul_add_n1 ZnZ.zero ZnZ.WW ZnZ.OW - (DoubleMul.w_mul_add ZnZ.zero ZnZ.succ ZnZ.add_c ZnZ.mul_c) - (S m) x y z in - ZnZ.to_Z q * (base (ZnZ.digits (nmake_op _ (dom_op n) (S m)))) - + eval n (S m) r = - eval n (S m) x * ZnZ.to_Z y + ZnZ.to_Z z. - Proof. - intros n m x y z. - rewrite digits_nmake. - unfold eval. rewrite nmake_double. - apply DoubleMul.spec_double_mul_add_n1. - apply ZnZ.spec_0. - exact ZnZ.spec_WW. - exact ZnZ.spec_OW. - apply DoubleCyclic.spec_mul_add. - Qed. - - Lemma spec_wn_mul : forall n m x y, - [wn_mul n m x y] = (eval n (S m) x) * ZnZ.to_Z y. - Proof. - intros; unfold wn_mul. - generalize (spec_mul_add_n1 n m x y ZnZ.zero). - case DoubleMul.double_mul_add_n1; intros q r Hqr. - rewrite ZnZ.spec_0, Z.add_0_r in Hqr. rewrite <- Hqr. - generalize (ZnZ.spec_eq0 q); case ZnZ.eq0; intros HH. - rewrite HH; auto. simpl. apply spec_mk_t_w'. - clear. - rewrite spec_mk_t_w'. - set (m' := S m) in *. - unfold eval. - rewrite nmake_WW. f_equal. f_equal. - rewrite <- spec_mk_t. - symmetry. apply spec_extend. - Qed. - - Theorem spec_mul : forall x y, [mul x y] = [x] * [y]. - Proof. - intros x y. rewrite mul_fold. apply spec_iter_sym; clear x y. - intros n x y. cbv zeta beta. - rewrite spec_reduce, spec_succ_t, <- ZnZ.spec_mul_c; auto. - apply spec_wn_mul. - intros n m x y; unfold mulnm. rewrite spec_reduce_n. - rewrite (spec_cast_l n m x), (spec_cast_r n m y). - apply spec_muln. - intros. rewrite Z.mul_comm; auto. - Qed. - - (** * Division by a smaller number *) - - Definition wn_divn1 n := - let op := dom_op n in - let zd := ZnZ.zdigits op in - let zero := ZnZ.zero in - let ww := ZnZ.WW in - let head0 := ZnZ.head0 in - let add_mul_div := ZnZ.add_mul_div in - let div21 := ZnZ.div21 in - let compare := ZnZ.compare in - let sub := ZnZ.sub in - let ddivn1 := - DoubleDivn1.double_divn1 zd zero ww head0 add_mul_div div21 compare sub in - fun m x y => let (u,v) := ddivn1 (S m) x y in (mk_t_w' n m u, mk_t n v). - - Definition div_gtnm n m wx wy := - let mn := Max.max n m in - let d := diff n m in - let op := make_op mn in - let (q, r):= ZnZ.div_gt - (castm (diff_r n m) (extend_tr wx (snd d))) - (castm (diff_l n m) (extend_tr wy (fst d))) in - (reduce_n mn q, reduce_n mn r). - - Local Notation div_gt_folded := - (iter _ - (fun n => let div_gt := ZnZ.div_gt in - fun x y => let (u,v) := div_gt x y in (reduce n u, reduce n v)) - (fun n => - let div_gt := ZnZ.div_gt in - fun m x y => - let y' := DoubleBase.get_low (zeron n) (S m) y in - let (u,v) := div_gt x y' in (reduce n u, reduce n v)) - wn_divn1 - div_gtnm). - - Definition div_gt := - Eval lazy beta iota delta - [iter dom_op dom_t reduce zeron wn_divn1 mk_t_w' mk_t] in - div_gt_folded. - - Lemma div_gt_fold : div_gt = div_gt_folded. - Proof. - lazy beta iota delta [iter dom_op dom_t reduce zeron wn_divn1 mk_t_w' mk_t]. - reflexivity. - Qed. - - Lemma spec_get_endn: forall n m x y, - eval n m x <= [mk_t n y] -> - [mk_t n (DoubleBase.get_low (zeron n) m x)] = eval n m x. - Proof. - intros n m x y H. - unfold eval. rewrite nmake_double. - rewrite spec_mk_t in *. - apply DoubleBase.spec_get_low. - apply spec_zeron. - exact ZnZ.spec_to_Z. - apply Z.le_lt_trans with (ZnZ.to_Z y); auto. - rewrite <- nmake_double; auto. - case (ZnZ.spec_to_Z y); auto. - Qed. - - Definition spec_divn1 n := - DoubleDivn1.spec_double_divn1 - (ZnZ.zdigits (dom_op n)) (ZnZ.zero:dom_t n) - ZnZ.WW ZnZ.head0 - ZnZ.add_mul_div ZnZ.div21 - ZnZ.compare ZnZ.sub ZnZ.to_Z - ZnZ.spec_to_Z - ZnZ.spec_zdigits - ZnZ.spec_0 ZnZ.spec_WW ZnZ.spec_head0 - ZnZ.spec_add_mul_div ZnZ.spec_div21 - ZnZ.spec_compare ZnZ.spec_sub. - - Lemma spec_div_gt_aux : forall x y, [x] > [y] -> 0 < [y] -> - let (q,r) := div_gt x y in - [x] = [q] * [y] + [r] /\ 0 <= [r] < [y]. - Proof. - intros x y. rewrite div_gt_fold. apply spec_iter; clear x y. - intros n x y H1 H2. simpl. - generalize (ZnZ.spec_div_gt x y H1 H2); case ZnZ.div_gt. - intros u v. rewrite 2 spec_reduce. auto. - intros n m x y H1 H2. cbv zeta beta. - generalize (ZnZ.spec_div_gt x - (DoubleBase.get_low (zeron n) (S m) y)). - case ZnZ.div_gt. - intros u v H3; repeat rewrite spec_reduce. - generalize (spec_get_endn n (S m) y x). rewrite !spec_mk_t. intros H4. - rewrite H4 in H3; auto with zarith. - intros n m x y H1 H2. - generalize (spec_divn1 n (S m) x y H2). - unfold wn_divn1; case DoubleDivn1.double_divn1. - intros u v H3. - rewrite spec_mk_t_w', spec_mk_t. - rewrite <- !nmake_double in H3; auto. - intros n m x y H1 H2; unfold div_gtnm. - generalize (ZnZ.spec_div_gt - (castm (diff_r n m) - (extend_tr x (snd (diff n m)))) - (castm (diff_l n m) - (extend_tr y (fst (diff n m))))). - case ZnZ.div_gt. - intros xx yy HH. - repeat rewrite spec_reduce_n. - rewrite (spec_cast_l n m x), (spec_cast_r n m y). - unfold to_Z; apply HH. - rewrite (spec_cast_l n m x) in H1; auto. - rewrite (spec_cast_r n m y) in H1; auto. - rewrite (spec_cast_r n m y) in H2; auto. - Qed. - - Theorem spec_div_gt: forall x y, [x] > [y] -> 0 < [y] -> - let (q,r) := div_gt x y in - [q] = [x] / [y] /\ [r] = [x] mod [y]. - Proof. - intros x y H1 H2; generalize (spec_div_gt_aux x y H1 H2); case div_gt. - intros q r (H3, H4); split. - apply (Zdiv_unique [x] [y] [q] [r]); auto. - rewrite Z.mul_comm; auto. - apply (Zmod_unique [x] [y] [q] [r]); auto. - rewrite Z.mul_comm; auto. - Qed. - - (** * General Division *) - - Definition div_eucl (x y : t) : t * t := - if eqb y zero then (zero,zero) else - match compare x y with - | Eq => (one, zero) - | Lt => (zero, x) - | Gt => div_gt x y - end. - - Theorem spec_div_eucl: forall x y, - let (q,r) := div_eucl x y in - ([q], [r]) = Z.div_eucl [x] [y]. - Proof. - intros x y. unfold div_eucl. - rewrite spec_eqb, spec_compare, spec_0. - case Z.eqb_spec. - intros ->. rewrite spec_0. destruct [x]; auto. - intros H'. - assert (H : 0 < [y]) by (generalize (spec_pos y); auto with zarith). - clear H'. - case Z.compare_spec; intros Cmp; - rewrite ?spec_0, ?spec_1; intros; auto with zarith. - rewrite Cmp; generalize (Z_div_same [y] (Z.lt_gt _ _ H)) - (Z_mod_same [y] (Z.lt_gt _ _ H)); - unfold Z.div, Z.modulo; case Z.div_eucl; intros; subst; auto. - assert (LeLt: 0 <= [x] < [y]) by (generalize (spec_pos x); auto). - generalize (Zdiv_small _ _ LeLt) (Zmod_small _ _ LeLt); - unfold Z.div, Z.modulo; case Z.div_eucl; intros; subst; auto. - generalize (spec_div_gt _ _ (Z.lt_gt _ _ Cmp) H); auto. - unfold Z.div, Z.modulo; case Z.div_eucl; case div_gt. - intros a b c d (H1, H2); subst; auto. - Qed. - - Definition div (x y : t) : t := fst (div_eucl x y). - - Theorem spec_div: - forall x y, [div x y] = [x] / [y]. - Proof. - intros x y; unfold div; generalize (spec_div_eucl x y); - case div_eucl; simpl fst. - intros xx yy; unfold Z.div; case Z.div_eucl; intros qq rr H; - injection H; auto. - Qed. - - (** * Modulo by a smaller number *) - - Definition wn_modn1 n := - let op := dom_op n in - let zd := ZnZ.zdigits op in - let zero := ZnZ.zero in - let head0 := ZnZ.head0 in - let add_mul_div := ZnZ.add_mul_div in - let div21 := ZnZ.div21 in - let compare := ZnZ.compare in - let sub := ZnZ.sub in - let dmodn1 := - DoubleDivn1.double_modn1 zd zero head0 add_mul_div div21 compare sub in - fun m x y => reduce n (dmodn1 (S m) x y). - - Definition mod_gtnm n m wx wy := - let mn := Max.max n m in - let d := diff n m in - let op := make_op mn in - reduce_n mn (ZnZ.modulo_gt - (castm (diff_r n m) (extend_tr wx (snd d))) - (castm (diff_l n m) (extend_tr wy (fst d)))). - - Local Notation mod_gt_folded := - (iter _ - (fun n => let modulo_gt := ZnZ.modulo_gt in - fun x y => reduce n (modulo_gt x y)) - (fun n => let modulo_gt := ZnZ.modulo_gt in - fun m x y => - reduce n (modulo_gt x (DoubleBase.get_low (zeron n) (S m) y))) - wn_modn1 - mod_gtnm). - - Definition mod_gt := - Eval lazy beta iota delta [iter dom_op dom_t reduce wn_modn1 zeron] in - mod_gt_folded. - - Lemma mod_gt_fold : mod_gt = mod_gt_folded. - Proof. - lazy beta iota delta [iter dom_op dom_t reduce wn_modn1 zeron]. - reflexivity. - Qed. - - Definition spec_modn1 n := - DoubleDivn1.spec_double_modn1 - (ZnZ.zdigits (dom_op n)) (ZnZ.zero:dom_t n) - ZnZ.WW ZnZ.head0 - ZnZ.add_mul_div ZnZ.div21 - ZnZ.compare ZnZ.sub ZnZ.to_Z - ZnZ.spec_to_Z - ZnZ.spec_zdigits - ZnZ.spec_0 ZnZ.spec_WW ZnZ.spec_head0 - ZnZ.spec_add_mul_div ZnZ.spec_div21 - ZnZ.spec_compare ZnZ.spec_sub. - - Theorem spec_mod_gt: - forall x y, [x] > [y] -> 0 < [y] -> [mod_gt x y] = [x] mod [y]. - Proof. - intros x y. rewrite mod_gt_fold. apply spec_iter; clear x y. - intros n x y H1 H2. simpl. rewrite spec_reduce. - exact (ZnZ.spec_modulo_gt x y H1 H2). - intros n m x y H1 H2. cbv zeta beta. rewrite spec_reduce. - rewrite <- spec_mk_t in H1. - rewrite <- (spec_get_endn n (S m) y x); auto with zarith. - rewrite spec_mk_t. - apply ZnZ.spec_modulo_gt; auto. - rewrite <- (spec_get_endn n (S m) y x), !spec_mk_t in H1; auto with zarith. - rewrite <- (spec_get_endn n (S m) y x), !spec_mk_t in H2; auto with zarith. - intros n m x y H1 H2. unfold wn_modn1. rewrite spec_reduce. - unfold eval; rewrite nmake_double. - apply (spec_modn1 n); auto. - intros n m x y H1 H2; unfold mod_gtnm. - repeat rewrite spec_reduce_n. - rewrite (spec_cast_l n m x), (spec_cast_r n m y). - unfold to_Z; apply ZnZ.spec_modulo_gt. - rewrite (spec_cast_l n m x) in H1; auto. - rewrite (spec_cast_r n m y) in H1; auto. - rewrite (spec_cast_r n m y) in H2; auto. - Qed. - - (** * General Modulo *) - - Definition modulo (x y : t) : t := - if eqb y zero then zero else - match compare x y with - | Eq => zero - | Lt => x - | Gt => mod_gt x y - end. - - Theorem spec_modulo: - forall x y, [modulo x y] = [x] mod [y]. - Proof. - intros x y. unfold modulo. - rewrite spec_eqb, spec_compare, spec_0. - case Z.eqb_spec. - intros ->; rewrite spec_0. destruct [x]; auto. - intro H'. - assert (H : 0 < [y]) by (generalize (spec_pos y); auto with zarith). - clear H'. - case Z.compare_spec; - rewrite ?spec_0, ?spec_1; intros; try split; auto with zarith. - rewrite H0; symmetry; apply Z_mod_same; auto with zarith. - symmetry; apply Zmod_small; auto with zarith. - generalize (spec_pos x); auto with zarith. - apply spec_mod_gt; auto with zarith. - Qed. - - (** * Square *) - - Local Notation squaren := (fun n => - let square_c := ZnZ.square_c in - fun x => reduce (S n) (succ_t _ (square_c x))). - - Definition square : t -> t := Eval red_t in iter_t squaren. - - Lemma square_fold : square = iter_t squaren. - Proof. red_t; reflexivity. Qed. - - Theorem spec_square: forall x, [square x] = [x] * [x]. - Proof. - intros x. rewrite square_fold. destr_t x as (n,x). - rewrite spec_succ_t. exact (ZnZ.spec_square_c x). - Qed. - - (** * Square Root *) - - Local Notation sqrtn := (fun n => - let sqrt := ZnZ.sqrt in - fun x => reduce n (sqrt x)). - - Definition sqrt : t -> t := Eval red_t in iter_t sqrtn. - - Lemma sqrt_fold : sqrt = iter_t sqrtn. - Proof. red_t; reflexivity. Qed. - - Theorem spec_sqrt_aux: forall x, [sqrt x] ^ 2 <= [x] < ([sqrt x] + 1) ^ 2. - Proof. - intros x. rewrite sqrt_fold. destr_t x as (n,x). exact (ZnZ.spec_sqrt x). - Qed. - - Theorem spec_sqrt: forall x, [sqrt x] = Z.sqrt [x]. - Proof. - intros x. - symmetry. apply Z.sqrt_unique. - rewrite <- ! Z.pow_2_r. apply spec_sqrt_aux. - Qed. - - (** * Power *) - - Fixpoint pow_pos (x:t)(p:positive) : t := - match p with - | xH => x - | xO p => square (pow_pos x p) - | xI p => mul (square (pow_pos x p)) x - end. - - Theorem spec_pow_pos: forall x n, [pow_pos x n] = [x] ^ Zpos n. - Proof. - intros x n; generalize x; elim n; clear n x; simpl pow_pos. - intros; rewrite spec_mul; rewrite spec_square; rewrite H. - rewrite Pos2Z.inj_xI; rewrite Zpower_exp; auto with zarith. - rewrite (Z.mul_comm 2); rewrite Z.pow_mul_r; auto with zarith. - rewrite Z.pow_2_r; rewrite Z.pow_1_r; auto. - intros; rewrite spec_square; rewrite H. - rewrite Pos2Z.inj_xO; auto with zarith. - rewrite (Z.mul_comm 2); rewrite Z.pow_mul_r; auto with zarith. - rewrite Z.pow_2_r; auto. - intros; rewrite Z.pow_1_r; auto. - Qed. - - Definition pow_N (x:t)(n:N) : t := match n with - | BinNat.N0 => one - | BinNat.Npos p => pow_pos x p - end. - - Theorem spec_pow_N: forall x n, [pow_N x n] = [x] ^ Z.of_N n. - Proof. - destruct n; simpl. apply spec_1. - apply spec_pow_pos. - Qed. - - Definition pow (x y:t) : t := pow_N x (to_N y). - - Theorem spec_pow : forall x y, [pow x y] = [x] ^ [y]. - Proof. - intros. unfold pow, to_N. - now rewrite spec_pow_N, Z2N.id by apply spec_pos. - Qed. - - - (** * digits - - Number of digits in the representation of a numbers - (including head zero's). - NB: This function isn't a morphism for setoid [eq]. - *) - - Local Notation digitsn := (fun n => - let digits := ZnZ.digits (dom_op n) in - fun _ => digits). - - Definition digits : t -> positive := Eval red_t in iter_t digitsn. - - Lemma digits_fold : digits = iter_t digitsn. - Proof. red_t; reflexivity. Qed. - - Theorem spec_digits: forall x, 0 <= [x] < 2 ^ Zpos (digits x). - Proof. - intros x. rewrite digits_fold. destr_t x as (n,x). exact (ZnZ.spec_to_Z x). - Qed. - - Lemma digits_level : forall x, digits x = ZnZ.digits (dom_op (level x)). - Proof. - intros x. rewrite digits_fold. unfold level. destr_t x as (n,x). reflexivity. - Qed. - - (** * Gcd *) - - Definition gcd_gt_body a b cont := - match compare b zero with - | Gt => - let r := mod_gt a b in - match compare r zero with - | Gt => cont r (mod_gt b r) - | _ => b - end - | _ => a - end. - - Theorem Zspec_gcd_gt_body: forall a b cont p, - [a] > [b] -> [a] < 2 ^ p -> - (forall a1 b1, [a1] < 2 ^ (p - 1) -> [a1] > [b1] -> - Zis_gcd [a1] [b1] [cont a1 b1]) -> - Zis_gcd [a] [b] [gcd_gt_body a b cont]. - Proof. - intros a b cont p H2 H3 H4; unfold gcd_gt_body. - rewrite ! spec_compare, spec_0. case Z.compare_spec. - intros ->; apply Zis_gcd_0. - intros HH; absurd (0 <= [b]); auto with zarith. - case (spec_digits b); auto with zarith. - intros H5; case Z.compare_spec. - intros H6; rewrite <- (Z.mul_1_r [b]). - rewrite (Z_div_mod_eq [a] [b]); auto with zarith. - rewrite <- spec_mod_gt; auto with zarith. - rewrite H6; rewrite Z.add_0_r. - apply Zis_gcd_mult; apply Zis_gcd_1. - intros; apply False_ind. - case (spec_digits (mod_gt a b)); auto with zarith. - intros H6; apply DoubleDiv.Zis_gcd_mod; auto with zarith. - apply DoubleDiv.Zis_gcd_mod; auto with zarith. - rewrite <- spec_mod_gt; auto with zarith. - assert (F2: [b] > [mod_gt a b]). - case (Z_mod_lt [a] [b]); auto with zarith. - repeat rewrite <- spec_mod_gt; auto with zarith. - assert (F3: [mod_gt a b] > [mod_gt b (mod_gt a b)]). - case (Z_mod_lt [b] [mod_gt a b]); auto with zarith. - rewrite <- spec_mod_gt; auto with zarith. - repeat rewrite <- spec_mod_gt; auto with zarith. - apply H4; auto with zarith. - apply Z.mul_lt_mono_pos_r with 2; auto with zarith. - apply Z.le_lt_trans with ([b] + [mod_gt a b]); auto with zarith. - apply Z.le_lt_trans with (([a]/[b]) * [b] + [mod_gt a b]); auto with zarith. - - apply Z.add_le_mono_r. - rewrite <- (Z.mul_1_l [b]) at 1. - apply Z.mul_le_mono_nonneg_r; auto with zarith. - change 1 with (Z.succ 0). apply Z.le_succ_l. - apply Z.div_str_pos; auto with zarith. - - rewrite Z.mul_comm; rewrite spec_mod_gt; auto with zarith. - rewrite <- Z_div_mod_eq; auto with zarith. - rewrite Z.mul_comm, <- Z.pow_succ_r, Z.sub_1_r, Z.succ_pred; auto. - apply Z.le_0_sub. change 1 with (Z.succ 0). apply Z.le_succ_l. - destruct p; simpl in H3; auto with zarith. - Qed. - - Fixpoint gcd_gt_aux (p:positive) (cont:t->t->t) (a b:t) : t := - gcd_gt_body a b - (fun a b => - match p with - | xH => cont a b - | xO p => gcd_gt_aux p (gcd_gt_aux p cont) a b - | xI p => gcd_gt_aux p (gcd_gt_aux p cont) a b - end). - - Theorem Zspec_gcd_gt_aux: forall p n a b cont, - [a] > [b] -> [a] < 2 ^ (Zpos p + n) -> - (forall a1 b1, [a1] < 2 ^ n -> [a1] > [b1] -> - Zis_gcd [a1] [b1] [cont a1 b1]) -> - Zis_gcd [a] [b] [gcd_gt_aux p cont a b]. - intros p; elim p; clear p. - intros p Hrec n a b cont H2 H3 H4. - unfold gcd_gt_aux; apply Zspec_gcd_gt_body with (Zpos (xI p) + n); auto. - intros a1 b1 H6 H7. - apply Hrec with (Zpos p + n); auto. - replace (Zpos p + (Zpos p + n)) with - (Zpos (xI p) + n - 1); auto. - rewrite Pos2Z.inj_xI; ring. - intros a2 b2 H9 H10. - apply Hrec with n; auto. - intros p Hrec n a b cont H2 H3 H4. - unfold gcd_gt_aux; apply Zspec_gcd_gt_body with (Zpos (xO p) + n); auto. - intros a1 b1 H6 H7. - apply Hrec with (Zpos p + n - 1); auto. - replace (Zpos p + (Zpos p + n - 1)) with - (Zpos (xO p) + n - 1); auto. - rewrite Pos2Z.inj_xO; ring. - intros a2 b2 H9 H10. - apply Hrec with (n - 1); auto. - replace (Zpos p + (n - 1)) with - (Zpos p + n - 1); auto with zarith. - intros a3 b3 H12 H13; apply H4; auto with zarith. - apply Z.lt_le_trans with (1 := H12). - apply Z.pow_le_mono_r; auto with zarith. - intros n a b cont H H2 H3. - simpl gcd_gt_aux. - apply Zspec_gcd_gt_body with (n + 1); auto with zarith. - rewrite Z.add_comm; auto. - intros a1 b1 H5 H6; apply H3; auto. - replace n with (n + 1 - 1); auto; try ring. - Qed. - - Definition gcd_cont a b := - match compare one b with - | Eq => one - | _ => a - end. - - Definition gcd_gt a b := gcd_gt_aux (digits a) gcd_cont a b. - - Theorem spec_gcd_gt: forall a b, - [a] > [b] -> [gcd_gt a b] = Z.gcd [a] [b]. - Proof. - intros a b H2. - case (spec_digits (gcd_gt a b)); intros H3 H4. - case (spec_digits a); intros H5 H6. - symmetry; apply Zis_gcd_gcd; auto with zarith. - unfold gcd_gt; apply Zspec_gcd_gt_aux with 0; auto with zarith. - intros a1 a2; rewrite Z.pow_0_r. - case (spec_digits a2); intros H7 H8; - intros; apply False_ind; auto with zarith. - Qed. - - Definition gcd (a b : t) : t := - match compare a b with - | Eq => a - | Lt => gcd_gt b a - | Gt => gcd_gt a b - end. - - Theorem spec_gcd: forall a b, [gcd a b] = Z.gcd [a] [b]. - Proof. - intros a b. - case (spec_digits a); intros H1 H2. - case (spec_digits b); intros H3 H4. - unfold gcd. rewrite spec_compare. case Z.compare_spec. - intros HH; rewrite HH; symmetry; apply Zis_gcd_gcd; auto. - apply Zis_gcd_refl. - intros; transitivity (Z.gcd [b] [a]). - apply spec_gcd_gt; auto with zarith. - apply Zis_gcd_gcd; auto with zarith. - apply Z.gcd_nonneg. - apply Zis_gcd_sym; apply Zgcd_is_gcd. - intros; apply spec_gcd_gt; auto with zarith. - Qed. - - (** * Parity test *) - - Definition even : t -> bool := Eval red_t in - iter_t (fun n x => ZnZ.is_even x). - - Definition odd x := negb (even x). - - Lemma even_fold : even = iter_t (fun n x => ZnZ.is_even x). - Proof. red_t; reflexivity. Qed. - - Theorem spec_even_aux: forall x, - if even x then [x] mod 2 = 0 else [x] mod 2 = 1. - Proof. - intros x. rewrite even_fold. destr_t x as (n,x). - exact (ZnZ.spec_is_even x). - Qed. - - Theorem spec_even: forall x, even x = Z.even [x]. - Proof. - intros x. assert (H := spec_even_aux x). symmetry. - rewrite (Z.div_mod [x] 2); auto with zarith. - destruct (even x); rewrite H, ?Z.add_0_r. - rewrite Zeven_bool_iff. apply Zeven_2p. - apply not_true_is_false. rewrite Zeven_bool_iff. - apply Zodd_not_Zeven. apply Zodd_2p_plus_1. - Qed. - - Theorem spec_odd: forall x, odd x = Z.odd [x]. - Proof. - intros x. unfold odd. - assert (H := spec_even_aux x). symmetry. - rewrite (Z.div_mod [x] 2); auto with zarith. - destruct (even x); rewrite H, ?Z.add_0_r; simpl negb. - apply not_true_is_false. rewrite Zodd_bool_iff. - apply Zeven_not_Zodd. apply Zeven_2p. - apply Zodd_bool_iff. apply Zodd_2p_plus_1. - Qed. - - (** * Conversion *) - - Definition pheight p := - Peano.pred (Pos.to_nat (get_height (ZnZ.digits (dom_op 0)) (plength p))). - - Theorem pheight_correct: forall p, - Zpos p < 2 ^ (Zpos (ZnZ.digits (dom_op 0)) * 2 ^ (Z.of_nat (pheight p))). - Proof. - intros p; unfold pheight. - rewrite Nat2Z.inj_pred by apply Pos2Nat.is_pos. - rewrite positive_nat_Z. - rewrite <- Z.sub_1_r. - assert (F2:= (get_height_correct (ZnZ.digits (dom_op 0)) (plength p))). - apply Z.lt_le_trans with (Zpos (Pos.succ p)). - rewrite Pos2Z.inj_succ; auto with zarith. - apply Z.le_trans with (1 := plength_pred_correct (Pos.succ p)). - rewrite Pos.pred_succ. - apply Z.pow_le_mono_r; auto with zarith. - Qed. - - Definition of_pos (x:positive) : t := - let n := pheight x in - reduce n (snd (ZnZ.of_pos x)). - - Theorem spec_of_pos: forall x, - [of_pos x] = Zpos x. - Proof. - intros x; unfold of_pos. - rewrite spec_reduce. - simpl. - apply ZnZ.of_pos_correct. - unfold base. - apply Z.lt_le_trans with (1 := pheight_correct x). - apply Z.pow_le_mono_r; auto with zarith. - rewrite (digits_dom_op (_ _)), Pshiftl_nat_Zpower. auto with zarith. - Qed. - - Definition of_N (x:N) : t := - match x with - | BinNat.N0 => zero - | Npos p => of_pos p - end. - - Theorem spec_of_N: forall x, - [of_N x] = Z.of_N x. - Proof. - intros x; case x. - simpl of_N. exact spec_0. - intros p; exact (spec_of_pos p). - Qed. - - (** * [head0] and [tail0] - - Number of zero at the beginning and at the end of - the representation of the number. - NB: these functions are not morphism for setoid [eq]. - *) - - Local Notation head0n := (fun n => - let head0 := ZnZ.head0 in - fun x => reduce n (head0 x)). - - Definition head0 : t -> t := Eval red_t in iter_t head0n. - - Lemma head0_fold : head0 = iter_t head0n. - Proof. red_t; reflexivity. Qed. - - Theorem spec_head00: forall x, [x] = 0 -> [head0 x] = Zpos (digits x). - Proof. - intros x. rewrite head0_fold, digits_fold. destr_t x as (n,x). - exact (ZnZ.spec_head00 x). - Qed. - - Lemma pow2_pos_minus_1 : forall z, 0<z -> 2^(z-1) = 2^z / 2. - Proof. - intros. apply Zdiv_unique with 0; auto with zarith. - change 2 with (2^1) at 2. - rewrite <- Zpower_exp; auto with zarith. - rewrite Z.add_0_r. f_equal. auto with zarith. - Qed. - - Theorem spec_head0: forall x, 0 < [x] -> - 2 ^ (Zpos (digits x) - 1) <= 2 ^ [head0 x] * [x] < 2 ^ Zpos (digits x). - Proof. - intros x. rewrite pow2_pos_minus_1 by (red; auto). - rewrite head0_fold, digits_fold. destr_t x as (n,x). exact (ZnZ.spec_head0 x). - Qed. - - Local Notation tail0n := (fun n => - let tail0 := ZnZ.tail0 in - fun x => reduce n (tail0 x)). - - Definition tail0 : t -> t := Eval red_t in iter_t tail0n. - - Lemma tail0_fold : tail0 = iter_t tail0n. - Proof. red_t; reflexivity. Qed. - - Theorem spec_tail00: forall x, [x] = 0 -> [tail0 x] = Zpos (digits x). - Proof. - intros x. rewrite tail0_fold, digits_fold. destr_t x as (n,x). - exact (ZnZ.spec_tail00 x). - Qed. - - Theorem spec_tail0: forall x, - 0 < [x] -> exists y, 0 <= y /\ [x] = (2 * y + 1) * 2 ^ [tail0 x]. - Proof. - intros x. rewrite tail0_fold. destr_t x as (n,x). exact (ZnZ.spec_tail0 x). - Qed. - - (** * [Ndigits] - - Same as [digits] but encoded using large integers - NB: this function is not a morphism for setoid [eq]. - *) - - Local Notation Ndigitsn := (fun n => - let d := reduce n (ZnZ.zdigits (dom_op n)) in - fun _ => d). - - Definition Ndigits : t -> t := Eval red_t in iter_t Ndigitsn. - - Lemma Ndigits_fold : Ndigits = iter_t Ndigitsn. - Proof. red_t; reflexivity. Qed. - - Theorem spec_Ndigits: forall x, [Ndigits x] = Zpos (digits x). - Proof. - intros x. rewrite Ndigits_fold, digits_fold. destr_t x as (n,x). - apply ZnZ.spec_zdigits. - Qed. - - (** * Binary logarithm *) - - Local Notation log2n := (fun n => - let op := dom_op n in - let zdigits := ZnZ.zdigits op in - let head0 := ZnZ.head0 in - let sub_carry := ZnZ.sub_carry in - fun x => reduce n (sub_carry zdigits (head0 x))). - - Definition log2 : t -> t := Eval red_t in - let log2 := iter_t log2n in - fun x => if eqb x zero then zero else log2 x. - - Lemma log2_fold : - log2 = fun x => if eqb x zero then zero else iter_t log2n x. - Proof. red_t; reflexivity. Qed. - - Lemma spec_log2_0 : forall x, [x] = 0 -> [log2 x] = 0. - Proof. - intros x H. rewrite log2_fold. - rewrite spec_eqb, H. rewrite spec_0. simpl. exact spec_0. - Qed. - - Lemma head0_zdigits : forall n (x : dom_t n), - 0 < ZnZ.to_Z x -> - ZnZ.to_Z (ZnZ.head0 x) < ZnZ.to_Z (ZnZ.zdigits (dom_op n)). - Proof. - intros n x H. - destruct (ZnZ.spec_head0 x H) as (_,H0). - intros. - assert (H1 := ZnZ.spec_to_Z (ZnZ.head0 x)). - assert (H2 := ZnZ.spec_to_Z (ZnZ.zdigits (dom_op n))). - unfold base in *. - rewrite ZnZ.spec_zdigits in H2 |- *. - set (h := ZnZ.to_Z (ZnZ.head0 x)) in *; clearbody h. - set (d := ZnZ.digits (dom_op n)) in *; clearbody d. - destruct (Z_lt_le_dec h (Zpos d)); auto. exfalso. - assert (1 * 2^Zpos d <= ZnZ.to_Z x * 2^h). - apply Z.mul_le_mono_nonneg; auto with zarith. - apply Z.pow_le_mono_r; auto with zarith. - rewrite Z.mul_comm in H0. auto with zarith. - Qed. - - Lemma spec_log2_pos : forall x, [x]<>0 -> - 2^[log2 x] <= [x] < 2^([log2 x]+1). - Proof. - intros x H. rewrite log2_fold. - rewrite spec_eqb. rewrite spec_0. - case Z.eqb_spec. - auto with zarith. - clear H. - destr_t x as (n,x). intros H. - rewrite ZnZ.spec_sub_carry. - assert (H0 := ZnZ.spec_to_Z x). - assert (H1 := ZnZ.spec_to_Z (ZnZ.head0 x)). - assert (H2 := ZnZ.spec_to_Z (ZnZ.zdigits (dom_op n))). - assert (H3 := head0_zdigits n x). - rewrite Zmod_small by auto with zarith. - rewrite Z.sub_simpl_r. - rewrite (Z.mul_lt_mono_pos_l (2^(ZnZ.to_Z (ZnZ.head0 x)))); - auto with zarith. - rewrite (Z.mul_le_mono_pos_l _ _ (2^(ZnZ.to_Z (ZnZ.head0 x)))); - auto with zarith. - rewrite <- 2 Zpower_exp; auto with zarith. - rewrite !Z.add_sub_assoc, !Z.add_simpl_l. - rewrite ZnZ.spec_zdigits. - rewrite pow2_pos_minus_1 by (red; auto). - apply ZnZ.spec_head0; auto with zarith. - Qed. - - Lemma spec_log2 : forall x, [log2 x] = Z.log2 [x]. - Proof. - intros. destruct (Z_lt_ge_dec 0 [x]). - symmetry. apply Z.log2_unique. apply spec_pos. - apply spec_log2_pos. intro EQ; rewrite EQ in *; auto with zarith. - rewrite spec_log2_0. rewrite Z.log2_nonpos; auto with zarith. - generalize (spec_pos x); auto with zarith. - Qed. - - Lemma log2_digits_head0 : forall x, 0 < [x] -> - [log2 x] = Zpos (digits x) - [head0 x] - 1. - Proof. - intros. rewrite log2_fold. - rewrite spec_eqb. rewrite spec_0. - case Z.eqb_spec. - auto with zarith. - intros _. revert H. rewrite digits_fold, head0_fold. destr_t x as (n,x). - rewrite ZnZ.spec_sub_carry. - intros. - generalize (head0_zdigits n x H). - generalize (ZnZ.spec_to_Z (ZnZ.head0 x)). - generalize (ZnZ.spec_to_Z (ZnZ.zdigits (dom_op n))). - rewrite ZnZ.spec_zdigits. intros. apply Zmod_small. - auto with zarith. - Qed. - - (** * Right shift *) - - Local Notation shiftrn := (fun n => - let op := dom_op n in - let zdigits := ZnZ.zdigits op in - let sub_c := ZnZ.sub_c in - let add_mul_div := ZnZ.add_mul_div in - let zzero := ZnZ.zero in - fun x p => match sub_c zdigits p with - | C0 d => reduce n (add_mul_div d zzero x) - | C1 _ => zero - end). - - Definition shiftr : t -> t -> t := Eval red_t in - same_level shiftrn. - - Lemma shiftr_fold : shiftr = same_level shiftrn. - Proof. red_t; reflexivity. Qed. - - Lemma div_pow2_bound :forall x y z, - 0 <= x -> 0 <= y -> x < z -> 0 <= x / 2 ^ y < z. - Proof. - intros x y z HH HH1 HH2. - split; auto with zarith. - apply Z.le_lt_trans with (2 := HH2); auto with zarith. - apply Zdiv_le_upper_bound; auto with zarith. - pattern x at 1; replace x with (x * 2 ^ 0); auto with zarith. - apply Z.mul_le_mono_nonneg_l; auto. - apply Z.pow_le_mono_r; auto with zarith. - rewrite Z.pow_0_r; ring. - Qed. - - Theorem spec_shiftr_pow2 : forall x n, - [shiftr x n] = [x] / 2 ^ [n]. - Proof. - intros x y. rewrite shiftr_fold. apply spec_same_level. clear x y. - intros n x p. simpl. - assert (Hx := ZnZ.spec_to_Z x). - assert (Hy := ZnZ.spec_to_Z p). - generalize (ZnZ.spec_sub_c (ZnZ.zdigits (dom_op n)) p). - case ZnZ.sub_c; intros d H; unfold interp_carry in *; simpl. - (** Subtraction without underflow : [ p <= digits ] *) - rewrite spec_reduce. - rewrite ZnZ.spec_zdigits in H. - rewrite ZnZ.spec_add_mul_div by auto with zarith. - rewrite ZnZ.spec_0, Z.mul_0_l, Z.add_0_l. - rewrite Zmod_small. - f_equal. f_equal. auto with zarith. - split. auto with zarith. - apply div_pow2_bound; auto with zarith. - (** Subtraction with underflow : [ digits < p ] *) - rewrite ZnZ.spec_0. symmetry. - apply Zdiv_small. - split; auto with zarith. - apply Z.lt_le_trans with (base (ZnZ.digits (dom_op n))); auto with zarith. - unfold base. apply Z.pow_le_mono_r; auto with zarith. - rewrite ZnZ.spec_zdigits in H. - generalize (ZnZ.spec_to_Z d); auto with zarith. - Qed. - - Lemma spec_shiftr: forall x p, [shiftr x p] = Z.shiftr [x] [p]. - Proof. - intros. - now rewrite spec_shiftr_pow2, Z.shiftr_div_pow2 by apply spec_pos. - Qed. - - (** * Left shift *) - - (** First an unsafe version, working correctly only if - the representation is large enough *) - - Local Notation unsafe_shiftln := (fun n => - let op := dom_op n in - let add_mul_div := ZnZ.add_mul_div in - let zero := ZnZ.zero in - fun x p => reduce n (add_mul_div p x zero)). - - Definition unsafe_shiftl : t -> t -> t := Eval red_t in - same_level unsafe_shiftln. - - Lemma unsafe_shiftl_fold : unsafe_shiftl = same_level unsafe_shiftln. - Proof. red_t; reflexivity. Qed. - - Theorem spec_unsafe_shiftl_aux : forall x p K, - 0 <= K -> - [x] < 2^K -> - [p] + K <= Zpos (digits x) -> - [unsafe_shiftl x p] = [x] * 2 ^ [p]. - Proof. - intros x p. - rewrite unsafe_shiftl_fold. rewrite digits_level. - apply spec_same_level_dep. - intros n m z z' r LE H K HK H1 H2. apply (H K); auto. - transitivity (Zpos (ZnZ.digits (dom_op n))); auto. - apply digits_dom_op_incr; auto. - clear x p. - intros n x p K HK Hx Hp. simpl. rewrite spec_reduce. - destruct (ZnZ.spec_to_Z x). - destruct (ZnZ.spec_to_Z p). - rewrite ZnZ.spec_add_mul_div by (omega with *). - rewrite ZnZ.spec_0, Zdiv_0_l, Z.add_0_r. - apply Zmod_small. unfold base. - split; auto with zarith. - rewrite Z.mul_comm. - apply Z.lt_le_trans with (2^(ZnZ.to_Z p + K)). - rewrite Zpower_exp; auto with zarith. - apply Z.mul_lt_mono_pos_l; auto with zarith. - apply Z.pow_le_mono_r; auto with zarith. - Qed. - - Theorem spec_unsafe_shiftl: forall x p, - [p] <= [head0 x] -> [unsafe_shiftl x p] = [x] * 2 ^ [p]. - Proof. - intros. - destruct (Z.eq_dec [x] 0) as [EQ|NEQ]. - (* [x] = 0 *) - apply spec_unsafe_shiftl_aux with 0; auto with zarith. - now rewrite EQ. - rewrite spec_head00 in *; auto with zarith. - (* [x] <> 0 *) - apply spec_unsafe_shiftl_aux with ([log2 x] + 1); auto with zarith. - generalize (spec_pos (log2 x)); auto with zarith. - destruct (spec_log2_pos x); auto with zarith. - rewrite log2_digits_head0; auto with zarith. - generalize (spec_pos x); auto with zarith. - Qed. - - (** Then we define a function doubling the size of the representation - but without changing the value of the number. *) - - Local Notation double_size_n := (fun n => - let zero := ZnZ.zero in - fun x => mk_t_S n (WW zero x)). - - Definition double_size : t -> t := Eval red_t in - iter_t double_size_n. - - Lemma double_size_fold : double_size = iter_t double_size_n. - Proof. red_t; reflexivity. Qed. - - Lemma double_size_level : forall x, level (double_size x) = S (level x). - Proof. - intros x. rewrite double_size_fold; unfold level at 2. destr_t x as (n,x). - apply mk_t_S_level. - Qed. - - Theorem spec_double_size_digits: - forall x, Zpos (digits (double_size x)) = 2 * (Zpos (digits x)). - Proof. - intros x. rewrite ! digits_level, double_size_level. - rewrite 2 digits_dom_op, 2 Pshiftl_nat_Zpower, - Nat2Z.inj_succ, Z.pow_succ_r; auto with zarith. - ring. - Qed. - - Theorem spec_double_size: forall x, [double_size x] = [x]. - Proof. - intros x. rewrite double_size_fold. destr_t x as (n,x). - rewrite spec_mk_t_S. simpl. rewrite ZnZ.spec_0. auto with zarith. - Qed. - - Theorem spec_double_size_head0: - forall x, 2 * [head0 x] <= [head0 (double_size x)]. - Proof. - intros x. - assert (F1:= spec_pos (head0 x)). - assert (F2: 0 < Zpos (digits x)). - red; auto. - assert (HH := spec_pos x). Z.le_elim HH. - generalize HH; rewrite <- (spec_double_size x); intros HH1. - case (spec_head0 x HH); intros _ HH2. - case (spec_head0 _ HH1). - rewrite (spec_double_size x); rewrite (spec_double_size_digits x). - intros HH3 _. - case (Z.le_gt_cases ([head0 (double_size x)]) (2 * [head0 x])); auto; intros HH4. - absurd (2 ^ (2 * [head0 x] )* [x] < 2 ^ [head0 (double_size x)] * [x]); auto. - apply Z.le_ngt. - apply Z.mul_le_mono_nonneg_r; auto with zarith. - apply Z.pow_le_mono_r; auto; auto with zarith. - assert (HH5: 2 ^[head0 x] <= 2 ^(Zpos (digits x) - 1)). - { apply Z.le_succ_l in HH. change (1 <= [x]) in HH. - Z.le_elim HH. - - apply Z.mul_le_mono_pos_r with (2 ^ 1); auto with zarith. - rewrite <- (fun x y z => Z.pow_add_r x (y - z)); auto with zarith. - rewrite Z.sub_add. - apply Z.le_trans with (2 := Z.lt_le_incl _ _ HH2). - apply Z.mul_le_mono_nonneg_l; auto with zarith. - rewrite Z.pow_1_r; auto with zarith. - - apply Z.pow_le_mono_r; auto with zarith. - case (Z.le_gt_cases (Zpos (digits x)) [head0 x]); auto with zarith; intros HH6. - absurd (2 ^ Zpos (digits x) <= 2 ^ [head0 x] * [x]); auto with zarith. - rewrite <- HH; rewrite Z.mul_1_r. - apply Z.pow_le_mono_r; auto with zarith. } - rewrite (Z.mul_comm 2). - rewrite Z.pow_mul_r; auto with zarith. - rewrite Z.pow_2_r. - apply Z.lt_le_trans with (2 := HH3). - rewrite <- Z.mul_assoc. - replace (2 * Zpos (digits x) - 1) with - ((Zpos (digits x) - 1) + (Zpos (digits x))). - rewrite Zpower_exp; auto with zarith. - apply Zmult_lt_compat2; auto with zarith. - split; auto with zarith. - apply Z.mul_pos_pos; auto with zarith. - rewrite Pos2Z.inj_xO; ring. - apply Z.lt_le_incl; auto. - repeat rewrite spec_head00; auto. - rewrite spec_double_size_digits. - rewrite Pos2Z.inj_xO; auto with zarith. - rewrite spec_double_size; auto. - Qed. - - Theorem spec_double_size_head0_pos: - forall x, 0 < [head0 (double_size x)]. - Proof. - intros x. - assert (F := Pos2Z.is_pos (digits x)). - assert (F0 := spec_pos (head0 (double_size x))). - Z.le_elim F0; auto. - assert (F1 := spec_pos (head0 x)). - Z.le_elim F1. - apply Z.lt_le_trans with (2 := (spec_double_size_head0 x)); auto with zarith. - assert (F3 := spec_pos x). - Z.le_elim F3. - generalize F3; rewrite <- (spec_double_size x); intros F4. - absurd (2 ^ (Zpos (xO (digits x)) - 1) < 2 ^ (Zpos (digits x))). - { apply Z.le_ngt. - apply Z.pow_le_mono_r; auto with zarith. - rewrite Pos2Z.inj_xO; auto with zarith. } - case (spec_head0 x F3). - rewrite <- F1; rewrite Z.pow_0_r; rewrite Z.mul_1_l; intros _ HH. - apply Z.le_lt_trans with (2 := HH). - case (spec_head0 _ F4). - rewrite (spec_double_size x); rewrite (spec_double_size_digits x). - rewrite <- F0; rewrite Z.pow_0_r; rewrite Z.mul_1_l; auto. - generalize F1; rewrite (spec_head00 _ (eq_sym F3)); auto with zarith. - Qed. - - (** Finally we iterate [double_size] enough before [unsafe_shiftl] - in order to get a fully correct [shiftl]. *) - - Definition shiftl_aux_body cont x n := - match compare n (head0 x) with - Gt => cont (double_size x) n - | _ => unsafe_shiftl x n - end. - - Theorem spec_shiftl_aux_body: forall n x p cont, - 2^ Zpos p <= [head0 x] -> - (forall x, 2 ^ (Zpos p + 1) <= [head0 x]-> - [cont x n] = [x] * 2 ^ [n]) -> - [shiftl_aux_body cont x n] = [x] * 2 ^ [n]. - Proof. - intros n x p cont H1 H2; unfold shiftl_aux_body. - rewrite spec_compare; case Z.compare_spec; intros H. - apply spec_unsafe_shiftl; auto with zarith. - apply spec_unsafe_shiftl; auto with zarith. - rewrite H2. - rewrite spec_double_size; auto. - rewrite Z.add_comm; rewrite Zpower_exp; auto with zarith. - apply Z.le_trans with (2 := spec_double_size_head0 x). - rewrite Z.pow_1_r; apply Z.mul_le_mono_nonneg_l; auto with zarith. - Qed. - - Fixpoint shiftl_aux p cont x n := - shiftl_aux_body - (fun x n => match p with - | xH => cont x n - | xO p => shiftl_aux p (shiftl_aux p cont) x n - | xI p => shiftl_aux p (shiftl_aux p cont) x n - end) x n. - - Theorem spec_shiftl_aux: forall p q x n cont, - 2 ^ (Zpos q) <= [head0 x] -> - (forall x, 2 ^ (Zpos p + Zpos q) <= [head0 x] -> - [cont x n] = [x] * 2 ^ [n]) -> - [shiftl_aux p cont x n] = [x] * 2 ^ [n]. - Proof. - intros p; elim p; unfold shiftl_aux; fold shiftl_aux; clear p. - intros p Hrec q x n cont H1 H2. - apply spec_shiftl_aux_body with (q); auto. - intros x1 H3; apply Hrec with (q + 1)%positive; auto. - intros x2 H4; apply Hrec with (p + q + 1)%positive; auto. - rewrite <- Pos.add_assoc. - rewrite Pos2Z.inj_add; auto. - intros x3 H5; apply H2. - rewrite Pos2Z.inj_xI. - replace (2 * Zpos p + 1 + Zpos q) with (Zpos p + Zpos (p + q + 1)); - auto. - rewrite !Pos2Z.inj_add; ring. - intros p Hrec q n x cont H1 H2. - apply spec_shiftl_aux_body with (q); auto. - intros x1 H3; apply Hrec with (q); auto. - apply Z.le_trans with (2 := H3); auto with zarith. - apply Z.pow_le_mono_r; auto with zarith. - intros x2 H4; apply Hrec with (p + q)%positive; auto. - intros x3 H5; apply H2. - rewrite (Pos2Z.inj_xO p). - replace (2 * Zpos p + Zpos q) with (Zpos p + Zpos (p + q)); - auto. - rewrite Pos2Z.inj_add; ring. - intros q n x cont H1 H2. - apply spec_shiftl_aux_body with (q); auto. - rewrite Z.add_comm; auto. - Qed. - - Definition shiftl x n := - shiftl_aux_body - (shiftl_aux_body - (shiftl_aux (digits n) unsafe_shiftl)) x n. - - Theorem spec_shiftl_pow2 : forall x n, - [shiftl x n] = [x] * 2 ^ [n]. - Proof. - intros x n; unfold shiftl, shiftl_aux_body. - rewrite spec_compare; case Z.compare_spec; intros H. - apply spec_unsafe_shiftl; auto with zarith. - apply spec_unsafe_shiftl; auto with zarith. - rewrite <- (spec_double_size x). - rewrite spec_compare; case Z.compare_spec; intros H1. - apply spec_unsafe_shiftl; auto with zarith. - apply spec_unsafe_shiftl; auto with zarith. - rewrite <- (spec_double_size (double_size x)). - apply spec_shiftl_aux with 1%positive. - apply Z.le_trans with (2 := spec_double_size_head0 (double_size x)). - replace (2 ^ 1) with (2 * 1). - apply Z.mul_le_mono_nonneg_l; auto with zarith. - generalize (spec_double_size_head0_pos x); auto with zarith. - rewrite Z.pow_1_r; ring. - intros x1 H2; apply spec_unsafe_shiftl. - apply Z.le_trans with (2 := H2). - apply Z.le_trans with (2 ^ Zpos (digits n)); auto with zarith. - case (spec_digits n); auto with zarith. - apply Z.pow_le_mono_r; auto with zarith. - Qed. - - Lemma spec_shiftl: forall x p, [shiftl x p] = Z.shiftl [x] [p]. - Proof. - intros. - now rewrite spec_shiftl_pow2, Z.shiftl_mul_pow2 by apply spec_pos. - Qed. - - (** Other bitwise operations *) - - Definition testbit x n := odd (shiftr x n). - - Lemma spec_testbit: forall x p, testbit x p = Z.testbit [x] [p]. - Proof. - intros. unfold testbit. symmetry. - rewrite spec_odd, spec_shiftr. apply Z.testbit_odd. - Qed. - - Definition div2 x := shiftr x one. - - Lemma spec_div2: forall x, [div2 x] = Z.div2 [x]. - Proof. - intros. unfold div2. symmetry. - rewrite spec_shiftr, spec_1. apply Z.div2_spec. - Qed. - - Local Notation lorn := (fun n => - let op := dom_op n in - let lor := ZnZ.lor in - fun x y => reduce n (lor x y)). - - Definition lor : t -> t -> t := Eval red_t in same_level lorn. - - Lemma lor_fold : lor = same_level lorn. - Proof. red_t; reflexivity. Qed. - - Theorem spec_lor x y : [lor x y] = Z.lor [x] [y]. - Proof. - rewrite lor_fold. apply spec_same_level; clear x y. - intros n x y. simpl. rewrite spec_reduce. apply ZnZ.spec_lor. - Qed. - - Local Notation landn := (fun n => - let op := dom_op n in - let land := ZnZ.land in - fun x y => reduce n (land x y)). - - Definition land : t -> t -> t := Eval red_t in same_level landn. - - Lemma land_fold : land = same_level landn. - Proof. red_t; reflexivity. Qed. - - Theorem spec_land x y : [land x y] = Z.land [x] [y]. - Proof. - rewrite land_fold. apply spec_same_level; clear x y. - intros n x y. simpl. rewrite spec_reduce. apply ZnZ.spec_land. - Qed. - - Local Notation lxorn := (fun n => - let op := dom_op n in - let lxor := ZnZ.lxor in - fun x y => reduce n (lxor x y)). - - Definition lxor : t -> t -> t := Eval red_t in same_level lxorn. - - Lemma lxor_fold : lxor = same_level lxorn. - Proof. red_t; reflexivity. Qed. - - Theorem spec_lxor x y : [lxor x y] = Z.lxor [x] [y]. - Proof. - rewrite lxor_fold. apply spec_same_level; clear x y. - intros n x y. simpl. rewrite spec_reduce. apply ZnZ.spec_lxor. - Qed. - - Local Notation ldiffn := (fun n => - let op := dom_op n in - let lxor := ZnZ.lxor in - let land := ZnZ.land in - let m1 := ZnZ.minus_one in - fun x y => reduce n (land x (lxor y m1))). - - Definition ldiff : t -> t -> t := Eval red_t in same_level ldiffn. - - Lemma ldiff_fold : ldiff = same_level ldiffn. - Proof. red_t; reflexivity. Qed. - - Lemma ldiff_alt x y p : - 0 <= x < 2^p -> 0 <= y < 2^p -> - Z.ldiff x y = Z.land x (Z.lxor y (2^p - 1)). - Proof. - intros (Hx,Hx') (Hy,Hy'). - destruct p as [|p|p]. - - simpl in *; replace x with 0; replace y with 0; auto with zarith. - - rewrite <- Z.shiftl_1_l. change (_ - 1) with (Z.ones (Z.pos p)). - rewrite <- Z.ldiff_ones_l_low; trivial. - rewrite !Z.ldiff_land, Z.land_assoc. f_equal. - rewrite Z.land_ones; try easy. - symmetry. apply Z.mod_small; now split. - Z.le_elim Hy. - + now apply Z.log2_lt_pow2. - + now subst. - - simpl in *; omega. - Qed. - - Theorem spec_ldiff x y : [ldiff x y] = Z.ldiff [x] [y]. - Proof. - rewrite ldiff_fold. apply spec_same_level; clear x y. - intros n x y. simpl. rewrite spec_reduce. - rewrite ZnZ.spec_land, ZnZ.spec_lxor, ZnZ.spec_m1. - symmetry. apply ldiff_alt; apply ZnZ.spec_to_Z. - Qed. - -End Make. diff --git a/theories/Numbers/Natural/BigN/NMake_gen.ml b/theories/Numbers/Natural/BigN/NMake_gen.ml deleted file mode 100644 index 5177fae65f..0000000000 --- a/theories/Numbers/Natural/BigN/NMake_gen.ml +++ /dev/null @@ -1,1017 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) -(* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) -(************************************************************************) - -(*S NMake_gen.ml : this file generates NMake_gen.v *) - - -(*s The parameter that control the generation: *) - -let size = 6 (* how many times should we repeat the Z/nZ --> Z/2nZ - process before relying on a generic construct *) - -(*s Some utilities *) - -let rec iter_str n s = if n = 0 then "" else (iter_str (n-1) s) ^ s - -let rec iter_str_gen n f = if n < 0 then "" else (iter_str_gen (n-1) f) ^ (f n) - -let rec iter_name i j base sep = - if i >= j then base^(string_of_int i) - else (iter_name i (j-1) base sep)^sep^" "^base^(string_of_int j) - -let pr s = Printf.printf (s^^"\n") - -(*s The actual printing *) - -let _ = - -pr -"(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *) -(* \\VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) -(* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) -(************************************************************************) - -(** * NMake_gen *) - -(** From a cyclic Z/nZ representation to arbitrary precision natural numbers.*) - -(** Remark: File automatically generated by NMake_gen.ml, DO NOT EDIT ! *) - -Require Import BigNumPrelude ZArith Ndigits CyclicAxioms - DoubleType DoubleMul DoubleDivn1 DoubleCyclic Nbasic - Wf_nat StreamMemo. - -Module Make (W0:CyclicType) <: NAbstract. - - (** * The word types *) -"; - -pr " Local Notation w0 := W0.t."; -for i = 1 to size do - pr " Definition w%i := zn2z w%i." i (i-1) -done; -pr ""; - -pr " (** * The operation type classes for the word types *) -"; - -pr " Local Notation w0_op := W0.ops."; -for i = 1 to min 3 size do - pr " Instance w%i_op : ZnZ.Ops w%i := mk_zn2z_ops w%i_op." i i (i-1) -done; -for i = 4 to size do - pr " Instance w%i_op : ZnZ.Ops w%i := mk_zn2z_ops_karatsuba w%i_op." i i (i-1) -done; -for i = size+1 to size+3 do - pr " Instance w%i_op : ZnZ.Ops (word w%i %i) := mk_zn2z_ops_karatsuba w%i_op." i size (i-size) (i-1) -done; -pr ""; - - pr " Section Make_op."; - pr " Variable mk : forall w', ZnZ.Ops w' -> ZnZ.Ops (zn2z w')."; - pr ""; - pr " Fixpoint make_op_aux (n:nat) : ZnZ.Ops (word w%i (S n)):=" size; - pr " match n return ZnZ.Ops (word w%i (S n)) with" size; - pr " | O => w%i_op" (size+1); - pr " | S n1 =>"; - pr " match n1 return ZnZ.Ops (word w%i (S (S n1))) with" size; - pr " | O => w%i_op" (size+2); - pr " | S n2 =>"; - pr " match n2 return ZnZ.Ops (word w%i (S (S (S n2)))) with" size; - pr " | O => w%i_op" (size+3); - pr " | S n3 => mk _ (mk _ (mk _ (make_op_aux n3)))"; - pr " end"; - pr " end"; - pr " end."; - pr ""; - pr " End Make_op."; - pr ""; - pr " Definition omake_op := make_op_aux mk_zn2z_ops_karatsuba."; - pr ""; - pr ""; - pr " Definition make_op_list := dmemo_list _ omake_op."; - pr ""; - pr " Instance make_op n : ZnZ.Ops (word w%i (S n))" size; - pr " := dmemo_get _ omake_op n make_op_list."; - pr ""; - -pr " Ltac unfold_ops := unfold omake_op, make_op_aux, w%i_op, w%i_op." (size+3) (size+2); - -pr -" - Lemma make_op_omake: forall n, make_op n = omake_op n. - Proof. - intros n; unfold make_op, make_op_list. - refine (dmemo_get_correct _ _ _). - Qed. - - Theorem make_op_S: forall n, - make_op (S n) = mk_zn2z_ops_karatsuba (make_op n). - Proof. - intros n. do 2 rewrite make_op_omake. - revert n. fix IHn 1. - do 3 (destruct n; [unfold_ops; reflexivity|]). - simpl mk_zn2z_ops_karatsuba. simpl word in *. - rewrite <- (IHn n). auto. - Qed. - - (** * The main type [t], isomorphic with [exists n, word w0 n] *) -"; - - pr " Inductive t' :="; - for i = 0 to size do - pr " | N%i : w%i -> t'" i i - done; - pr " | Nn : forall n, word w%i (S n) -> t'." size; - pr ""; - pr " Definition t := t'."; - pr ""; - - pr " (** * A generic toolbox for building and deconstructing [t] *)"; - pr ""; - - pr " Local Notation SizePlus n := %sn%s." - (iter_str size "(S ") (iter_str size ")"); - pr " Local Notation Size := (SizePlus O)."; - pr ""; - - pr " Tactic Notation (at level 3) \"do_size\" tactic3(t) := do %i t." (size+1); - pr ""; - - pr " Definition dom_t n := match n with"; - for i = 0 to size do - pr " | %i => w%i" i i; - done; - pr " | %sn => word w%i n" (if size=0 then "" else "SizePlus ") size; - pr " end."; - pr ""; - -pr -" Instance dom_op n : ZnZ.Ops (dom_t n) | 10. - Proof. - do_size (destruct n; [simpl;auto with *|]). - unfold dom_t. auto with *. - Defined. -"; - - pr " Definition iter_t {A:Type}(f : forall n, dom_t n -> A) : t -> A :="; - for i = 0 to size do - pr " let f%i := f %i in" i i; - done; - pr " let fn n := f (SizePlus (S n)) in"; - pr " fun x => match x with"; - for i = 0 to size do - pr " | N%i wx => f%i wx" i i; - done; - pr " | Nn n wx => fn n wx"; - pr " end."; - pr ""; - - pr " Definition mk_t (n:nat) : dom_t n -> t :="; - pr " match n as n' return dom_t n' -> t with"; - for i = 0 to size do - pr " | %i => N%i" i i; - done; - pr " | %s(S n) => Nn n" (if size=0 then "" else "SizePlus "); - pr " end."; - pr ""; - -pr -" Definition level := iter_t (fun n _ => n). - - Inductive View_t : t -> Prop := - Mk_t : forall n (x : dom_t n), View_t (mk_t n x). - - Lemma destr_t : forall x, View_t x. - Proof. - intros x. generalize (Mk_t (level x)). destruct x; simpl; auto. - Defined. - - Lemma iter_mk_t : forall A (f:forall n, dom_t n -> A), - forall n x, iter_t f (mk_t n x) = f n x. - Proof. - do_size (destruct n; try reflexivity). - Qed. - - (** * Projection to ZArith *) - - Definition to_Z : t -> Z := - Eval lazy beta iota delta [iter_t dom_t dom_op] in - iter_t (fun _ x => ZnZ.to_Z x). - - Notation \"[ x ]\" := (to_Z x). - - Theorem spec_mk_t : forall n (x:dom_t n), [mk_t n x] = ZnZ.to_Z x. - Proof. - intros. change to_Z with (iter_t (fun _ x => ZnZ.to_Z x)). - rewrite iter_mk_t; auto. - Qed. - - (** * Regular make op, without memoization or karatsuba - - This will normally never be used for actual computations, - but only for specification purpose when using - [word (dom_t n) m] intermediate values. *) - - Fixpoint nmake_op (ww:Type) (ww_op: ZnZ.Ops ww) (n: nat) : - ZnZ.Ops (word ww n) := - match n return ZnZ.Ops (word ww n) with - O => ww_op - | S n1 => mk_zn2z_ops (nmake_op ww ww_op n1) - end. - - Definition eval n m := ZnZ.to_Z (Ops:=nmake_op _ (dom_op n) m). - - Theorem nmake_op_S: forall ww (w_op: ZnZ.Ops ww) x, - nmake_op _ w_op (S x) = mk_zn2z_ops (nmake_op _ w_op x). - Proof. - auto. - Qed. - - Theorem digits_nmake_S :forall n ww (w_op: ZnZ.Ops ww), - ZnZ.digits (nmake_op _ w_op (S n)) = - xO (ZnZ.digits (nmake_op _ w_op n)). - Proof. - auto. - Qed. - - Theorem digits_nmake : forall n ww (w_op: ZnZ.Ops ww), - ZnZ.digits (nmake_op _ w_op n) = Pos.shiftl_nat (ZnZ.digits w_op) n. - Proof. - induction n. auto. - intros ww ww_op. rewrite Pshiftl_nat_S, <- IHn; auto. - Qed. - - Theorem nmake_double: forall n ww (w_op: ZnZ.Ops ww), - ZnZ.to_Z (Ops:=nmake_op _ w_op n) = - @DoubleBase.double_to_Z _ (ZnZ.digits w_op) (ZnZ.to_Z (Ops:=w_op)) n. - Proof. - intros n; elim n; auto; clear n. - intros n Hrec ww ww_op; simpl DoubleBase.double_to_Z; unfold zn2z_to_Z. - rewrite <- Hrec; auto. - unfold DoubleBase.double_wB; rewrite <- digits_nmake; auto. - Qed. - - Theorem nmake_WW: forall ww ww_op n xh xl, - (ZnZ.to_Z (Ops:=nmake_op ww ww_op (S n)) (WW xh xl) = - ZnZ.to_Z (Ops:=nmake_op ww ww_op n) xh * - base (ZnZ.digits (nmake_op ww ww_op n)) + - ZnZ.to_Z (Ops:=nmake_op ww ww_op n) xl)%%Z. - Proof. - auto. - Qed. - - (** * The specification proofs for the word operators *) -"; - - if size <> 0 then - pr " Typeclasses Opaque %s." (iter_name 1 size "w" ""); - pr ""; - - pr " Instance w0_spec: ZnZ.Specs w0_op := W0.specs."; - for i = 1 to min 3 size do - pr " Instance w%i_spec: ZnZ.Specs w%i_op := mk_zn2z_specs w%i_spec." i i (i-1) - done; - for i = 4 to size do - pr " Instance w%i_spec: ZnZ.Specs w%i_op := mk_zn2z_specs_karatsuba w%i_spec." i i (i-1) - done; - pr " Instance w%i_spec: ZnZ.Specs w%i_op := mk_zn2z_specs_karatsuba w%i_spec." (size+1) (size+1) size; - - -pr " - Instance wn_spec (n:nat) : ZnZ.Specs (make_op n). - Proof. - induction n. - rewrite make_op_omake; simpl; auto with *. - rewrite make_op_S. exact (mk_zn2z_specs_karatsuba IHn). - Qed. - - Instance dom_spec n : ZnZ.Specs (dom_op n) | 10. - Proof. - do_size (destruct n; auto with *). apply wn_spec. - Qed. - - Let make_op_WW : forall n x y, - (ZnZ.to_Z (Ops:=make_op (S n)) (WW x y) = - ZnZ.to_Z (Ops:=make_op n) x * base (ZnZ.digits (make_op n)) - + ZnZ.to_Z (Ops:=make_op n) y)%%Z. - Proof. - intros n x y; rewrite make_op_S; auto. - Qed. - - (** * Zero *) - - Definition zero0 : w0 := ZnZ.zero. - - Definition zeron n : dom_t n := - match n with - | O => zero0 - | SizePlus (S n) => W0 - | _ => W0 - end. - - Lemma spec_zeron : forall n, ZnZ.to_Z (zeron n) = 0%%Z. - Proof. - do_size (destruct n; - [match goal with - |- @eq Z (_ (zeron ?n)) _ => - apply (ZnZ.spec_0 (Specs:=dom_spec n)) - end|]). - destruct n; auto. simpl. rewrite make_op_S. fold word. - apply (ZnZ.spec_0 (Specs:=wn_spec (SizePlus 0))). - Qed. - - (** * Digits *) - - Lemma digits_make_op_0 : forall n, - ZnZ.digits (make_op n) = Pos.shiftl_nat (ZnZ.digits (dom_op Size)) (S n). - Proof. - induction n. - auto. - replace (ZnZ.digits (make_op (S n))) with (xO (ZnZ.digits (make_op n))). - rewrite IHn; auto. - rewrite make_op_S; auto. - Qed. - - Lemma digits_make_op : forall n, - ZnZ.digits (make_op n) = Pos.shiftl_nat (ZnZ.digits w0_op) (SizePlus (S n)). - Proof. - intros. rewrite digits_make_op_0. - replace (SizePlus (S n)) with (S n + Size) by (rewrite <- plus_comm; auto). - rewrite Pshiftl_nat_plus. auto. - Qed. - - Lemma digits_dom_op : forall n, - ZnZ.digits (dom_op n) = Pos.shiftl_nat (ZnZ.digits w0_op) n. - Proof. - do_size (destruct n; try reflexivity). - exact (digits_make_op n). - Qed. - - Lemma digits_dom_op_nmake : forall n m, - ZnZ.digits (dom_op (m+n)) = ZnZ.digits (nmake_op _ (dom_op n) m). - Proof. - intros. rewrite digits_nmake, 2 digits_dom_op. apply Pshiftl_nat_plus. - Qed. - - (** * Conversion between [zn2z (dom_t n)] and [dom_t (S n)]. - - These two types are provably equal, but not convertible, - hence we need some work. We now avoid using generic casts - (i.e. rewrite via proof of equalities in types), since - proving things with them is a mess. - *) - - Definition succ_t n : zn2z (dom_t n) -> dom_t (S n) := - match n with - | SizePlus (S _) => fun x => x - | _ => fun x => x - end. - - Lemma spec_succ_t : forall n x, - ZnZ.to_Z (succ_t n x) = - zn2z_to_Z (base (ZnZ.digits (dom_op n))) ZnZ.to_Z x. - Proof. - do_size (destruct n ; [reflexivity|]). - intros. simpl. rewrite make_op_S. simpl. auto. - Qed. - - Definition pred_t n : dom_t (S n) -> zn2z (dom_t n) := - match n with - | SizePlus (S _) => fun x => x - | _ => fun x => x - end. - - Lemma succ_pred_t : forall n x, succ_t n (pred_t n x) = x. - Proof. - do_size (destruct n ; [reflexivity|]). reflexivity. - Qed. - - (** We can hence project from [zn2z (dom_t n)] to [t] : *) - - Definition mk_t_S n (x : zn2z (dom_t n)) : t := - mk_t (S n) (succ_t n x). - - Lemma spec_mk_t_S : forall n x, - [mk_t_S n x] = zn2z_to_Z (base (ZnZ.digits (dom_op n))) ZnZ.to_Z x. - Proof. - intros. unfold mk_t_S. rewrite spec_mk_t. apply spec_succ_t. - Qed. - - Lemma mk_t_S_level : forall n x, level (mk_t_S n x) = S n. - Proof. - intros. unfold mk_t_S, level. rewrite iter_mk_t; auto. - Qed. - - (** * Conversion from [word (dom_t n) m] to [dom_t (m+n)]. - - Things are more complex here. We start with a naive version - that breaks zn2z-trees and reconstruct them. Doing this is - quite unfortunate, but I don't know how to fully avoid that. - (cast someday ?). Then we build an optimized version where - all basic cases (n<=6 or m<=7) are nicely handled. - *) - - Definition zn2z_map {A} {B} (f:A->B) (x:zn2z A) : zn2z B := - match x with - | W0 => W0 - | WW h l => WW (f h) (f l) - end. - - Lemma zn2z_map_id : forall A f (x:zn2z A), (forall u, f u = u) -> - zn2z_map f x = x. - Proof. - destruct x; auto; intros. - simpl; f_equal; auto. - Qed. - - (** The naive version *) - - Fixpoint plus_t n m : word (dom_t n) m -> dom_t (m+n) := - match m as m' return word (dom_t n) m' -> dom_t (m'+n) with - | O => fun x => x - | S m => fun x => succ_t _ (zn2z_map (plus_t n m) x) - end. - - Theorem spec_plus_t : forall n m (x:word (dom_t n) m), - ZnZ.to_Z (plus_t n m x) = eval n m x. - Proof. - unfold eval. - induction m. - simpl; auto. - intros. - simpl plus_t; simpl plus. rewrite spec_succ_t. - destruct x. - simpl; auto. - fold word in w, w0. - simpl. rewrite 2 IHm. f_equal. f_equal. f_equal. - apply digits_dom_op_nmake. - Qed. - - Definition mk_t_w n m (x:word (dom_t n) m) : t := - mk_t (m+n) (plus_t n m x). - - Theorem spec_mk_t_w : forall n m (x:word (dom_t n) m), - [mk_t_w n m x] = eval n m x. - Proof. - intros. unfold mk_t_w. rewrite spec_mk_t. apply spec_plus_t. - Qed. - - (** The optimized version. - - NB: the last particular case for m could depend on n, - but it's simplier to just expand everywhere up to m=7 - (cf [mk_t_w'] later). - *) - - Definition plus_t' n : forall m, word (dom_t n) m -> dom_t (m+n) := - match n return (forall m, word (dom_t n) m -> dom_t (m+n)) with - | SizePlus (S n') as n => plus_t n - | _ as n => - fun m => match m return (word (dom_t n) m -> dom_t (m+n)) with - | SizePlus (S (S m')) as m => plus_t n m - | _ => fun x => x - end - end. - - Lemma plus_t_equiv : forall n m x, - plus_t' n m x = plus_t n m x. - Proof. - (do_size try destruct n); try reflexivity; - (do_size try destruct m); try destruct m; try reflexivity; - simpl; symmetry; repeat (intros; apply zn2z_map_id; trivial). - Qed. - - Lemma spec_plus_t' : forall n m x, - ZnZ.to_Z (plus_t' n m x) = eval n m x. - Proof. - intros; rewrite plus_t_equiv. apply spec_plus_t. - Qed. - - (** Particular cases [Nk x] = eval i j x with specific k,i,j - can be solved by the following tactic *) - - Ltac solve_eval := - intros; rewrite <- spec_plus_t'; unfold to_Z; simpl dom_op; reflexivity. - - (** The last particular case that remains useful *) - - Lemma spec_eval_size : forall n x, [Nn n x] = eval Size (S n) x. - Proof. - induction n. - solve_eval. - destruct x as [ | xh xl ]. - simpl. unfold eval. rewrite make_op_S. rewrite nmake_op_S. auto. - simpl word in xh, xl |- *. - unfold to_Z in *. rewrite make_op_WW. - unfold eval in *. rewrite nmake_WW. - f_equal; auto. - f_equal; auto. - f_equal. - rewrite <- digits_dom_op_nmake. rewrite plus_comm; auto. - Qed. - - (** An optimized [mk_t_w]. - - We could say mk_t_w' := mk_t _ (plus_t' n m x) - (TODO: WHY NOT, BTW ??). - Instead we directly define functions for all intersting [n], - reverting to naive [mk_t_w] at places that should normally - never be used (see [mul] and [div_gt]). - *) -"; - -for i = 0 to size-1 do -let pattern = (iter_str (size+1-i) "(S ") ^ "_" ^ (iter_str (size+1-i) ")") in -pr -" Definition mk_t_%iw m := Eval cbv beta zeta iota delta [ mk_t plus ] in - match m return word w%i (S m) -> t with - | %s as p => mk_t_w %i (S p) - | p => mk_t (%i+p) - end. -" i i pattern i (i+1) -done; - -pr -" Definition mk_t_w' n : forall m, word (dom_t n) (S m) -> t := - match n return (forall m, word (dom_t n) (S m) -> t) with"; -for i = 0 to size-1 do pr " | %i => mk_t_%iw" i i done; -pr -" | Size => Nn - | _ as n' => fun m => mk_t_w n' (S m) - end. -"; - -pr -" Ltac solve_spec_mk_t_w' := - rewrite <- spec_plus_t'; - match goal with _ : word (dom_t ?n) ?m |- _ => apply (spec_mk_t (n+m)) end. - - Theorem spec_mk_t_w' : - forall n m x, [mk_t_w' n m x] = eval n (S m) x. - Proof. - intros. - repeat (apply spec_mk_t_w || (destruct n; - [repeat (apply spec_mk_t_w || (destruct m; [solve_spec_mk_t_w'|]))|])). - apply spec_eval_size. - Qed. - - (** * Extend : injecting [dom_t n] into [word (dom_t n) (S m)] *) - - Definition extend n m (x:dom_t n) : word (dom_t n) (S m) := - DoubleBase.extend_aux m (WW (zeron n) x). - - Lemma spec_extend : forall n m x, - [mk_t n x] = eval n (S m) (extend n m x). - Proof. - intros. unfold eval, extend. - rewrite spec_mk_t. - assert (H : forall (x:dom_t n), - (ZnZ.to_Z (zeron n) * base (ZnZ.digits (dom_op n)) + ZnZ.to_Z x = - ZnZ.to_Z x)%%Z). - clear; intros; rewrite spec_zeron; auto. - rewrite <- (@DoubleBase.spec_extend _ - (WW (zeron n)) (ZnZ.digits (dom_op n)) ZnZ.to_Z H m x). - simpl. rewrite digits_nmake, <- nmake_double. auto. - Qed. - - (** A particular case of extend, used in [same_level]: - [extend_size] is [extend Size] *) - - Definition extend_size := DoubleBase.extend (WW (W0:dom_t Size)). - - Lemma spec_extend_size : forall n x, [mk_t Size x] = [Nn n (extend_size n x)]. - Proof. - intros. rewrite spec_eval_size. apply (spec_extend Size n). - Qed. - - (** Misc results about extensions *) - - Let spec_extend_WW : forall n x, - [Nn (S n) (WW W0 x)] = [Nn n x]. - Proof. - intros n x. - set (N:=SizePlus (S n)). - change ([Nn (S n) (extend N 0 x)]=[mk_t N x]). - rewrite (spec_extend N 0). - solve_eval. - Qed. - - Let spec_extend_tr: forall m n w, - [Nn (m + n) (extend_tr w m)] = [Nn n w]. - Proof. - induction m; auto. - intros n x; simpl extend_tr. - simpl plus; rewrite spec_extend_WW; auto. - Qed. - - Let spec_cast_l: forall n m x1, - [Nn n x1] = - [Nn (Max.max n m) (castm (diff_r n m) (extend_tr x1 (snd (diff n m))))]. - Proof. - intros n m x1; case (diff_r n m); simpl castm. - rewrite spec_extend_tr; auto. - Qed. - - Let spec_cast_r: forall n m x1, - [Nn m x1] = - [Nn (Max.max n m) (castm (diff_l n m) (extend_tr x1 (fst (diff n m))))]. - Proof. - intros n m x1; case (diff_l n m); simpl castm. - rewrite spec_extend_tr; auto. - Qed. - - Ltac unfold_lets := - match goal with - | h : _ |- _ => unfold h; clear h; unfold_lets - | _ => idtac - end. - - (** * [same_level] - - Generic binary operator construction, by extending the smaller - argument to the level of the other. - *) - - Section SameLevel. - - Variable res: Type. - Variable P : Z -> Z -> res -> Prop. - Variable f : forall n, dom_t n -> dom_t n -> res. - Variable Pf : forall n x y, P (ZnZ.to_Z x) (ZnZ.to_Z y) (f n x y). -"; - -for i = 0 to size do -pr " Let f%i : w%i -> w%i -> res := f %i." i i i i -done; -pr -" Let fn n := f (SizePlus (S n)). - - Let Pf' : - forall n x y u v, u = [mk_t n x] -> v = [mk_t n y] -> P u v (f n x y). - Proof. - intros. subst. rewrite 2 spec_mk_t. apply Pf. - Qed. -"; - -let ext i j s = - if j <= i then s else Printf.sprintf "(extend %i %i %s)" i (j-i-1) s -in - -pr " Notation same_level_folded := (fun x y => match x, y with"; -for i = 0 to size do - for j = 0 to size do - pr " | N%i wx, N%i wy => f%i %s %s" i j (max i j) (ext i j "wx") (ext j i "wy") - done; - pr " | N%i wx, Nn m wy => fn m (extend_size m %s) wy" i (ext i size "wx") -done; -for i = 0 to size do - pr " | Nn n wx, N%i wy => fn n wx (extend_size n %s)" i (ext i size "wy") -done; -pr -" | Nn n wx, Nn m wy => - let mn := Max.max n m in - let d := diff n m in - fn mn - (castm (diff_r n m) (extend_tr wx (snd d))) - (castm (diff_l n m) (extend_tr wy (fst d))) - end). -"; - -pr -" Definition same_level := Eval lazy beta iota delta - [ DoubleBase.extend DoubleBase.extend_aux extend zeron ] - in same_level_folded. - - Lemma spec_same_level_0: forall x y, P [x] [y] (same_level x y). - Proof. - change same_level with same_level_folded. unfold_lets. - destruct x, y; apply Pf'; simpl mk_t; rewrite <- ?spec_extend_size; - match goal with - | |- context [ extend ?n ?m _ ] => apply (spec_extend n m) - | |- context [ castm _ _ ] => apply spec_cast_l || apply spec_cast_r - | _ => reflexivity - end. - Qed. - - End SameLevel. - - Arguments same_level [res] f x y. - - Theorem spec_same_level_dep : - forall res - (P : nat -> Z -> Z -> res -> Prop) - (Pantimon : forall n m z z' r, n <= m -> P m z z' r -> P n z z' r) - (f : forall n, dom_t n -> dom_t n -> res) - (Pf: forall n x y, P n (ZnZ.to_Z x) (ZnZ.to_Z y) (f n x y)), - forall x y, P (level x) [x] [y] (same_level f x y). - Proof. - intros res P Pantimon f Pf. - set (f' := fun n x y => (n, f n x y)). - set (P' := fun z z' r => P (fst r) z z' (snd r)). - assert (FST : forall x y, level x <= fst (same_level f' x y)) - by (destruct x, y; simpl; omega with * ). - assert (SND : forall x y, same_level f x y = snd (same_level f' x y)) - by (destruct x, y; reflexivity). - intros. eapply Pantimon; [eapply FST|]. - rewrite SND. eapply (@spec_same_level_0 _ P' f'); eauto. - Qed. - - (** * [iter] - - Generic binary operator construction, by splitting the larger - argument in blocks and applying the smaller argument to them. - *) - - Section Iter. - - Variable res: Type. - Variable P: Z -> Z -> res -> Prop. - - Variable f : forall n, dom_t n -> dom_t n -> res. - Variable Pf : forall n x y, P (ZnZ.to_Z x) (ZnZ.to_Z y) (f n x y). - - Variable fd : forall n m, dom_t n -> word (dom_t n) (S m) -> res. - Variable fg : forall n m, word (dom_t n) (S m) -> dom_t n -> res. - Variable Pfd : forall n m x y, P (ZnZ.to_Z x) (eval n (S m) y) (fd n m x y). - Variable Pfg : forall n m x y, P (eval n (S m) x) (ZnZ.to_Z y) (fg n m x y). - - Variable fnm: forall n m, word (dom_t Size) (S n) -> word (dom_t Size) (S m) -> res. - Variable Pfnm: forall n m x y, P [Nn n x] [Nn m y] (fnm n m x y). - - Let Pf' : - forall n x y u v, u = [mk_t n x] -> v = [mk_t n y] -> P u v (f n x y). - Proof. - intros. subst. rewrite 2 spec_mk_t. apply Pf. - Qed. - - Let Pfd' : forall n m x y u v, u = [mk_t n x] -> v = eval n (S m) y -> - P u v (fd n m x y). - Proof. - intros. subst. rewrite spec_mk_t. apply Pfd. - Qed. - - Let Pfg' : forall n m x y u v, u = eval n (S m) x -> v = [mk_t n y] -> - P u v (fg n m x y). - Proof. - intros. subst. rewrite spec_mk_t. apply Pfg. - Qed. -"; - -for i = 0 to size do -pr " Let f%i := f %i." i i -done; - -for i = 0 to size do -pr " Let f%in := fd %i." i i; -pr " Let fn%i := fg %i." i i; -done; - -pr " Notation iter_folded := (fun x y => match x, y with"; -for i = 0 to size do - for j = 0 to size do - pr " | N%i wx, N%i wy => f%s wx wy" i j - (if i = j then string_of_int i - else if i < j then string_of_int i ^ "n " ^ string_of_int (j-i-1) - else "n" ^ string_of_int j ^ " " ^ string_of_int (i-j-1)) - done; - pr " | N%i wx, Nn m wy => f%in m %s wy" i size (ext i size "wx") -done; -for i = 0 to size do - pr " | Nn n wx, N%i wy => fn%i n wx %s" i size (ext i size "wy") -done; -pr -" | Nn n wx, Nn m wy => fnm n m wx wy - end). -"; - -pr -" Definition iter := Eval lazy beta iota delta - [extend DoubleBase.extend DoubleBase.extend_aux zeron] - in iter_folded. - - Lemma spec_iter: forall x y, P [x] [y] (iter x y). - Proof. - change iter with iter_folded; unfold_lets. - destruct x; destruct y; apply Pf' || apply Pfd' || apply Pfg' || apply Pfnm; - simpl mk_t; - match goal with - | |- ?x = ?x => reflexivity - | |- [Nn _ _] = _ => apply spec_eval_size - | |- context [extend ?n ?m _] => apply (spec_extend n m) - | _ => idtac - end; - unfold to_Z; rewrite <- spec_plus_t'; simpl dom_op; reflexivity. - Qed. - - End Iter. -"; - -pr -" Definition switch - (P:nat->Type)%s - (fn:forall n, P n) n := - match n return P n with" - (iter_str_gen size (fun i -> Printf.sprintf "(f%i:P %i)" i i)); -for i = 0 to size do pr " | %i => f%i" i i done; -pr -" | n => fn n - end. -"; - -pr -" Lemma spec_switch : forall P (f:forall n, P n) n, - switch P %sf n = f n. - Proof. - repeat (destruct n; try reflexivity). - Qed. -" (iter_str_gen size (fun i -> Printf.sprintf "(f %i) " i)); - -pr -" (** * [iter_sym] - - A variant of [iter] for symmetric functions, or pseudo-symmetric - functions (when f y x can be deduced from f x y). - *) - - Section IterSym. - - Variable res: Type. - Variable P: Z -> Z -> res -> Prop. - - Variable f : forall n, dom_t n -> dom_t n -> res. - Variable Pf : forall n x y, P (ZnZ.to_Z x) (ZnZ.to_Z y) (f n x y). - - Variable fg : forall n m, word (dom_t n) (S m) -> dom_t n -> res. - Variable Pfg : forall n m x y, P (eval n (S m) x) (ZnZ.to_Z y) (fg n m x y). - - Variable fnm: forall n m, word (dom_t Size) (S n) -> word (dom_t Size) (S m) -> res. - Variable Pfnm: forall n m x y, P [Nn n x] [Nn m y] (fnm n m x y). - - Variable opp: res -> res. - Variable Popp : forall u v r, P u v r -> P v u (opp r). -"; - -for i = 0 to size do -pr " Let f%i := f %i." i i -done; - -for i = 0 to size do -pr " Let fn%i := fg %i." i i; -done; - -pr " Let f' := switch _ %s f." (iter_name 0 size "f" ""); -pr " Let fg' := switch _ %s fg." (iter_name 0 size "fn" ""); - -pr -" Local Notation iter_sym_folded := - (iter res f' (fun n m x y => opp (fg' n m y x)) fg' fnm). - - Definition iter_sym := - Eval lazy beta zeta iota delta [iter f' fg' switch] in iter_sym_folded. - - Lemma spec_iter_sym: forall x y, P [x] [y] (iter_sym x y). - Proof. - intros. change iter_sym with iter_sym_folded. apply spec_iter; clear x y. - unfold_lets. - intros. rewrite spec_switch. auto. - intros. apply Popp. unfold_lets. rewrite spec_switch; auto. - intros. unfold_lets. rewrite spec_switch; auto. - auto. - Qed. - - End IterSym. - - (** * Reduction - - [reduce] can be used instead of [mk_t], it will choose the - lowest possible level. NB: We only search and remove leftmost - W0's via ZnZ.eq0, any non-W0 block ends the process, even - if its value is 0. - *) - - (** First, a direct version ... *) - - Fixpoint red_t n : dom_t n -> t := - match n return dom_t n -> t with - | O => N0 - | S n => fun x => - let x' := pred_t n x in - reduce_n1 _ _ (N0 zero0) ZnZ.eq0 (red_t n) (mk_t_S n) x' - end. - - Lemma spec_red_t : forall n x, [red_t n x] = [mk_t n x]. - Proof. - induction n. - reflexivity. - intros. - simpl red_t. unfold reduce_n1. - rewrite <- (succ_pred_t n x) at 2. - remember (pred_t n x) as x'. - rewrite spec_mk_t, spec_succ_t. - destruct x' as [ | xh xl]. simpl. apply ZnZ.spec_0. - generalize (ZnZ.spec_eq0 xh); case ZnZ.eq0; intros H. - rewrite IHn, spec_mk_t. simpl. rewrite H; auto. - apply spec_mk_t_S. - Qed. - - (** ... then a specialized one *) -"; - -for i = 0 to size do -pr " Definition eq0%i := @ZnZ.eq0 _ w%i_op." i i; -done; - -pr " - Definition reduce_0 := N0."; -for i = 1 to size do - pr " Definition reduce_%i :=" i; - pr " Eval lazy beta iota delta [reduce_n1] in"; - pr " reduce_n1 _ _ (N0 zero0) eq0%i reduce_%i N%i." (i-1) (i-1) i -done; - - pr " Definition reduce_%i :=" (size+1); - pr " Eval lazy beta iota delta [reduce_n1] in"; - pr " reduce_n1 _ _ (N0 zero0) eq0%i reduce_%i (Nn 0)." size size; - - pr " Definition reduce_n n :="; - pr " Eval lazy beta iota delta [reduce_n] in"; - pr " reduce_n _ _ (N0 zero0) reduce_%i Nn n." (size + 1); - pr ""; - -pr " Definition reduce n : dom_t n -> t :="; -pr " match n with"; -for i = 0 to size do -pr " | %i => reduce_%i" i i; -done; -pr " | %s(S n) => reduce_n n" (if size=0 then "" else "SizePlus "); -pr " end."; -pr ""; - -pr " Ltac unfold_red := unfold reduce, %s." (iter_name 1 size "reduce_" ","); -pr ""; -for i = 0 to size do -pr " Declare Equivalent Keys reduce reduce_%i." i; -done; -pr " Declare Equivalent Keys reduce_n reduce_%i." (size + 1); - -pr " - Ltac solve_red := - let H := fresh in let G := fresh in - match goal with - | |- ?P (S ?n) => assert (H:P n) by solve_red - | _ => idtac - end; - intros n G x; destruct (le_lt_eq_dec _ _ G) as [LT|EQ]; - solve [ - apply (H _ (lt_n_Sm_le _ _ LT)) | - inversion LT | - subst; change (reduce 0 x = red_t 0 x); reflexivity | - specialize (H (pred n)); subst; destruct x; - [|unfold_red; rewrite H; auto]; reflexivity - ]. - - Lemma reduce_equiv : forall n x, n <= Size -> reduce n x = red_t n x. - Proof. - set (P N := forall n, n <= N -> forall x, reduce n x = red_t n x). - intros n x H. revert n H x. change (P Size). solve_red. - Qed. - - Lemma spec_reduce_n : forall n x, [reduce_n n x] = [Nn n x]. - Proof. - assert (H : forall x, reduce_%i x = red_t (SizePlus 1) x). - destruct x; [|unfold reduce_%i; rewrite (reduce_equiv Size)]; auto. - induction n. - intros. rewrite H. apply spec_red_t. - destruct x as [|xh xl]. - simpl. rewrite make_op_S. exact ZnZ.spec_0. - fold word in *. - destruct xh; auto. - simpl reduce_n. - rewrite IHn. - rewrite spec_extend_WW; auto. - Qed. -" (size+1) (size+1); - -pr -" Lemma spec_reduce : forall n x, [reduce n x] = ZnZ.to_Z x. - Proof. - do_size (destruct n; - [intros; rewrite reduce_equiv;[apply spec_red_t|auto with arith]|]). - apply spec_reduce_n. - Qed. - -End Make. -"; diff --git a/theories/Numbers/Natural/BigN/Nbasic.v b/theories/Numbers/Natural/BigN/Nbasic.v deleted file mode 100644 index 18d0262c90..0000000000 --- a/theories/Numbers/Natural/BigN/Nbasic.v +++ /dev/null @@ -1,569 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) -(* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) -(************************************************************************) - -Require Import ZArith Ndigits. -Require Import BigNumPrelude. -Require Import Max. -Require Import DoubleType. -Require Import DoubleBase. -Require Import CyclicAxioms. -Require Import DoubleCyclic. - -Arguments mk_zn2z_ops [t] ops. -Arguments mk_zn2z_ops_karatsuba [t] ops. -Arguments mk_zn2z_specs [t ops] specs. -Arguments mk_zn2z_specs_karatsuba [t ops] specs. -Arguments ZnZ.digits [t] Ops. -Arguments ZnZ.zdigits [t] Ops. - -Lemma Pshiftl_nat_Zpower : forall n p, - Zpos (Pos.shiftl_nat p n) = Zpos p * 2 ^ Z.of_nat n. -Proof. - intros. - rewrite Z.mul_comm. - induction n. simpl; auto. - transitivity (2 * (2 ^ Z.of_nat n * Zpos p)). - rewrite <- IHn. auto. - rewrite Z.mul_assoc. - rewrite Nat2Z.inj_succ. - rewrite <- Z.pow_succ_r; auto with zarith. -Qed. - -(* To compute the necessary height *) - -Fixpoint plength (p: positive) : positive := - match p with - xH => xH - | xO p1 => Pos.succ (plength p1) - | xI p1 => Pos.succ (plength p1) - end. - -Theorem plength_correct: forall p, (Zpos p < 2 ^ Zpos (plength p))%Z. -assert (F: (forall p, 2 ^ (Zpos (Pos.succ p)) = 2 * 2 ^ Zpos p)%Z). -intros p; replace (Zpos (Pos.succ p)) with (1 + Zpos p)%Z. -rewrite Zpower_exp; auto with zarith. -rewrite Pos2Z.inj_succ; unfold Z.succ; auto with zarith. -intros p; elim p; simpl plength; auto. -intros p1 Hp1; rewrite F; repeat rewrite Pos2Z.inj_xI. -assert (tmp: (forall p, 2 * p = p + p)%Z); - try repeat rewrite tmp; auto with zarith. -intros p1 Hp1; rewrite F; rewrite (Pos2Z.inj_xO p1). -assert (tmp: (forall p, 2 * p = p + p)%Z); - try repeat rewrite tmp; auto with zarith. -rewrite Z.pow_1_r; auto with zarith. -Qed. - -Theorem plength_pred_correct: forall p, (Zpos p <= 2 ^ Zpos (plength (Pos.pred p)))%Z. -intros p; case (Pos.succ_pred_or p); intros H1. -subst; simpl plength. -rewrite Z.pow_1_r; auto with zarith. -pattern p at 1; rewrite <- H1. -rewrite Pos2Z.inj_succ; unfold Z.succ; auto with zarith. -generalize (plength_correct (Pos.pred p)); auto with zarith. -Qed. - -Definition Pdiv p q := - match Z.div (Zpos p) (Zpos q) with - Zpos q1 => match (Zpos p) - (Zpos q) * (Zpos q1) with - Z0 => q1 - | _ => (Pos.succ q1) - end - | _ => xH - end. - -Theorem Pdiv_le: forall p q, - Zpos p <= Zpos q * Zpos (Pdiv p q). -intros p q. -unfold Pdiv. -assert (H1: Zpos q > 0); auto with zarith. -assert (H1b: Zpos p >= 0); auto with zarith. -generalize (Z_div_ge0 (Zpos p) (Zpos q) H1 H1b). -generalize (Z_div_mod_eq (Zpos p) (Zpos q) H1); case Z.div. - intros HH _; rewrite HH; rewrite Z.mul_0_r; rewrite Z.mul_1_r; simpl. -case (Z_mod_lt (Zpos p) (Zpos q) H1); auto with zarith. -intros q1 H2. -replace (Zpos p - Zpos q * Zpos q1) with (Zpos p mod Zpos q). - 2: pattern (Zpos p) at 2; rewrite H2; auto with zarith. -generalize H2 (Z_mod_lt (Zpos p) (Zpos q) H1); clear H2; - case Z.modulo. - intros HH _; rewrite HH; auto with zarith. - intros r1 HH (_,HH1); rewrite HH; rewrite Pos2Z.inj_succ. - unfold Z.succ; rewrite Z.mul_add_distr_l; auto with zarith. - intros r1 _ (HH,_); case HH; auto. -intros q1 HH; rewrite HH. -unfold Z.ge; simpl Z.compare; intros HH1; case HH1; auto. -Qed. - -Definition is_one p := match p with xH => true | _ => false end. - -Theorem is_one_one: forall p, is_one p = true -> p = xH. -intros p; case p; auto; intros p1 H1; discriminate H1. -Qed. - -Definition get_height digits p := - let r := Pdiv p digits in - if is_one r then xH else Pos.succ (plength (Pos.pred r)). - -Theorem get_height_correct: - forall digits N, - Zpos N <= Zpos digits * (2 ^ (Zpos (get_height digits N) -1)). -intros digits N. -unfold get_height. -assert (H1 := Pdiv_le N digits). -case_eq (is_one (Pdiv N digits)); intros H2. -rewrite (is_one_one _ H2) in H1. -rewrite Z.mul_1_r in H1. -change (2^(1-1))%Z with 1; rewrite Z.mul_1_r; auto. -clear H2. -apply Z.le_trans with (1 := H1). -apply Z.mul_le_mono_nonneg_l; auto with zarith. -rewrite Pos2Z.inj_succ; unfold Z.succ. -rewrite Z.add_comm; rewrite Z.add_simpl_l. -apply plength_pred_correct. -Qed. - -Definition zn2z_word_comm : forall w n, zn2z (word w n) = word (zn2z w) n. - fix zn2z_word_comm 2. - intros w n; case n. - reflexivity. - intros n0;simpl. - case (zn2z_word_comm w n0). - reflexivity. -Defined. - -Fixpoint extend (n:nat) {struct n} : forall w:Type, zn2z w -> word w (S n) := - match n return forall w:Type, zn2z w -> word w (S n) with - | O => fun w x => x - | S m => - let aux := extend m in - fun w x => WW W0 (aux w x) - end. - -Section ExtendMax. - -Open Scope nat_scope. - -Fixpoint plusnS (n m: nat) {struct n} : (n + S m = S (n + m))%nat := - match n return (n + S m = S (n + m))%nat with - | 0 => eq_refl (S m) - | S n1 => - let v := S (S n1 + m) in - eq_ind_r (fun n => S n = v) (eq_refl v) (plusnS n1 m) - end. - -Fixpoint plusn0 n : n + 0 = n := - match n return (n + 0 = n) with - | 0 => eq_refl 0 - | S n1 => - let v := S n1 in - eq_ind_r (fun n : nat => S n = v) (eq_refl v) (plusn0 n1) - end. - - Fixpoint diff (m n: nat) {struct m}: nat * nat := - match m, n with - O, n => (O, n) - | m, O => (m, O) - | S m1, S n1 => diff m1 n1 - end. - -Fixpoint diff_l (m n : nat) {struct m} : fst (diff m n) + n = max m n := - match m return fst (diff m n) + n = max m n with - | 0 => - match n return (n = max 0 n) with - | 0 => eq_refl _ - | S n0 => eq_refl _ - end - | S m1 => - match n return (fst (diff (S m1) n) + n = max (S m1) n) - with - | 0 => plusn0 _ - | S n1 => - let v := fst (diff m1 n1) + n1 in - let v1 := fst (diff m1 n1) + S n1 in - eq_ind v (fun n => v1 = S n) - (eq_ind v1 (fun n => v1 = n) (eq_refl v1) (S v) (plusnS _ _)) - _ (diff_l _ _) - end - end. - -Fixpoint diff_r (m n: nat) {struct m}: snd (diff m n) + m = max m n := - match m return (snd (diff m n) + m = max m n) with - | 0 => - match n return (snd (diff 0 n) + 0 = max 0 n) with - | 0 => eq_refl _ - | S _ => plusn0 _ - end - | S m => - match n return (snd (diff (S m) n) + S m = max (S m) n) with - | 0 => eq_refl (snd (diff (S m) 0) + S m) - | S n1 => - let v := S (max m n1) in - eq_ind_r (fun n => n = v) - (eq_ind_r (fun n => S n = v) - (eq_refl v) (diff_r _ _)) (plusnS _ _) - end - end. - - Variable w: Type. - - Definition castm (m n: nat) (H: m = n) (x: word w (S m)): - (word w (S n)) := - match H in (_ = y) return (word w (S y)) with - | eq_refl => x - end. - -Variable m: nat. -Variable v: (word w (S m)). - -Fixpoint extend_tr (n : nat) {struct n}: (word w (S (n + m))) := - match n return (word w (S (n + m))) with - | O => v - | S n1 => WW W0 (extend_tr n1) - end. - -End ExtendMax. - -Arguments extend_tr [w m] v n. -Arguments castm [w m n] H x. - - - -Section Reduce. - - Variable w : Type. - Variable nT : Type. - Variable N0 : nT. - Variable eq0 : w -> bool. - Variable reduce_n : w -> nT. - Variable zn2z_to_Nt : zn2z w -> nT. - - Definition reduce_n1 (x:zn2z w) := - match x with - | W0 => N0 - | WW xh xl => - if eq0 xh then reduce_n xl - else zn2z_to_Nt x - end. - -End Reduce. - -Section ReduceRec. - - Variable w : Type. - Variable nT : Type. - Variable N0 : nT. - Variable reduce_1n : zn2z w -> nT. - Variable c : forall n, word w (S n) -> nT. - - Fixpoint reduce_n (n:nat) : word w (S n) -> nT := - match n return word w (S n) -> nT with - | O => reduce_1n - | S m => fun x => - match x with - | W0 => N0 - | WW xh xl => - match xh with - | W0 => @reduce_n m xl - | _ => @c (S m) x - end - end - end. - -End ReduceRec. - -Section CompareRec. - - Variable wm w : Type. - Variable w_0 : w. - Variable compare : w -> w -> comparison. - Variable compare0_m : wm -> comparison. - Variable compare_m : wm -> w -> comparison. - - Fixpoint compare0_mn (n:nat) : word wm n -> comparison := - match n return word wm n -> comparison with - | O => compare0_m - | S m => fun x => - match x with - | W0 => Eq - | WW xh xl => - match compare0_mn m xh with - | Eq => compare0_mn m xl - | r => Lt - end - end - end. - - Variable wm_base: positive. - Variable wm_to_Z: wm -> Z. - Variable w_to_Z: w -> Z. - Variable w_to_Z_0: w_to_Z w_0 = 0. - Variable spec_compare0_m: forall x, - compare0_m x = (w_to_Z w_0 ?= wm_to_Z x). - Variable wm_to_Z_pos: forall x, 0 <= wm_to_Z x < base wm_base. - - Let double_to_Z := double_to_Z wm_base wm_to_Z. - Let double_wB := double_wB wm_base. - - Lemma base_xO: forall n, base (xO n) = (base n)^2. - Proof. - intros n1; unfold base. - rewrite (Pos2Z.inj_xO n1); rewrite Z.mul_comm; rewrite Z.pow_mul_r; auto with zarith. - Qed. - - Let double_to_Z_pos: forall n x, 0 <= double_to_Z n x < double_wB n := - (spec_double_to_Z wm_base wm_to_Z wm_to_Z_pos). - - Declare Equivalent Keys compare0_mn compare0_m. - - Lemma spec_compare0_mn: forall n x, - compare0_mn n x = (0 ?= double_to_Z n x). - Proof. - intros n; elim n; clear n; auto. - intros x; rewrite spec_compare0_m; rewrite w_to_Z_0; auto. - intros n Hrec x; case x; unfold compare0_mn; fold compare0_mn; auto. - fold word in *. - intros xh xl. - rewrite 2 Hrec. - simpl double_to_Z. - set (wB := DoubleBase.double_wB wm_base n). - case Z.compare_spec; intros Cmp. - rewrite <- Cmp. reflexivity. - symmetry. apply Z.gt_lt, Z.lt_gt. (* ;-) *) - assert (0 < wB). - unfold wB, DoubleBase.double_wB, base; auto with zarith. - change 0 with (0 + 0); apply Z.add_lt_le_mono; auto with zarith. - apply Z.mul_pos_pos; auto with zarith. - case (double_to_Z_pos n xl); auto with zarith. - case (double_to_Z_pos n xh); intros; exfalso; omega. - Qed. - - Fixpoint compare_mn_1 (n:nat) : word wm n -> w -> comparison := - match n return word wm n -> w -> comparison with - | O => compare_m - | S m => fun x y => - match x with - | W0 => compare w_0 y - | WW xh xl => - match compare0_mn m xh with - | Eq => compare_mn_1 m xl y - | r => Gt - end - end - end. - - Variable spec_compare: forall x y, - compare x y = Z.compare (w_to_Z x) (w_to_Z y). - Variable spec_compare_m: forall x y, - compare_m x y = Z.compare (wm_to_Z x) (w_to_Z y). - Variable wm_base_lt: forall x, - 0 <= w_to_Z x < base (wm_base). - - Let double_wB_lt: forall n x, - 0 <= w_to_Z x < (double_wB n). - Proof. - intros n x; elim n; simpl; auto; clear n. - intros n (H0, H); split; auto. - apply Z.lt_le_trans with (1:= H). - unfold double_wB, DoubleBase.double_wB; simpl. - rewrite base_xO. - set (u := base (Pos.shiftl_nat wm_base n)). - assert (0 < u). - unfold u, base; auto with zarith. - replace (u^2) with (u * u); simpl; auto with zarith. - apply Z.le_trans with (1 * u); auto with zarith. - unfold Z.pow_pos; simpl; ring. - Qed. - - - Lemma spec_compare_mn_1: forall n x y, - compare_mn_1 n x y = Z.compare (double_to_Z n x) (w_to_Z y). - Proof. - intros n; elim n; simpl; auto; clear n. - intros n Hrec x; case x; clear x; auto. - intros y; rewrite spec_compare; rewrite w_to_Z_0. reflexivity. - intros xh xl y; simpl; - rewrite spec_compare0_mn, Hrec. case Z.compare_spec. - intros H1b. - rewrite <- H1b; rewrite Z.mul_0_l; rewrite Z.add_0_l; auto. - symmetry. apply Z.lt_gt. - case (double_wB_lt n y); intros _ H0. - apply Z.lt_le_trans with (1:= H0). - fold double_wB. - case (double_to_Z_pos n xl); intros H1 H2. - apply Z.le_trans with (double_to_Z n xh * double_wB n); auto with zarith. - apply Z.le_trans with (1 * double_wB n); auto with zarith. - case (double_to_Z_pos n xh); intros; exfalso; omega. - Qed. - -End CompareRec. - - -Section AddS. - - Variable w wm : Type. - Variable incr : wm -> carry wm. - Variable addr : w -> wm -> carry wm. - Variable injr : w -> zn2z wm. - - Variable w_0 u: w. - Fixpoint injs (n:nat): word w (S n) := - match n return (word w (S n)) with - O => WW w_0 u - | S n1 => (WW W0 (injs n1)) - end. - - Definition adds x y := - match y with - W0 => C0 (injr x) - | WW hy ly => match addr x ly with - C0 z => C0 (WW hy z) - | C1 z => match incr hy with - C0 z1 => C0 (WW z1 z) - | C1 z1 => C1 (WW z1 z) - end - end - end. - -End AddS. - - Fixpoint length_pos x := - match x with xH => O | xO x1 => S (length_pos x1) | xI x1 => S (length_pos x1) end. - - Theorem length_pos_lt: forall x y, - (length_pos x < length_pos y)%nat -> Zpos x < Zpos y. - Proof. - intros x; elim x; clear x; [intros x1 Hrec | intros x1 Hrec | idtac]; - intros y; case y; clear y; intros y1 H || intros H; simpl length_pos; - try (rewrite (Pos2Z.inj_xI x1) || rewrite (Pos2Z.inj_xO x1)); - try (rewrite (Pos2Z.inj_xI y1) || rewrite (Pos2Z.inj_xO y1)); - try (inversion H; fail); - try (assert (Zpos x1 < Zpos y1); [apply Hrec; apply lt_S_n | idtac]; auto with zarith); - assert (0 < Zpos y1); auto with zarith; red; auto. - Qed. - - Theorem cancel_app: forall A B (f g: A -> B) x, f = g -> f x = g x. - Proof. - intros A B f g x H; rewrite H; auto. - Qed. - - - Section SimplOp. - - Variable w: Type. - - Theorem digits_zop: forall t (ops : ZnZ.Ops t), - ZnZ.digits (mk_zn2z_ops ops) = xO (ZnZ.digits ops). - Proof. - intros ww x; auto. - Qed. - - Theorem digits_kzop: forall t (ops : ZnZ.Ops t), - ZnZ.digits (mk_zn2z_ops_karatsuba ops) = xO (ZnZ.digits ops). - Proof. - intros ww x; auto. - Qed. - - Theorem make_zop: forall t (ops : ZnZ.Ops t), - @ZnZ.to_Z _ (mk_zn2z_ops ops) = - fun z => match z with - | W0 => 0 - | WW xh xl => ZnZ.to_Z xh * base (ZnZ.digits ops) - + ZnZ.to_Z xl - end. - Proof. - intros ww x; auto. - Qed. - - Theorem make_kzop: forall t (ops: ZnZ.Ops t), - @ZnZ.to_Z _ (mk_zn2z_ops_karatsuba ops) = - fun z => match z with - | W0 => 0 - | WW xh xl => ZnZ.to_Z xh * base (ZnZ.digits ops) - + ZnZ.to_Z xl - end. - Proof. - intros ww x; auto. - Qed. - - End SimplOp. - -(** Abstract vision of a datatype of arbitrary-large numbers. - Concrete operations can be derived from these generic - fonctions, in particular from [iter_t] and [same_level]. -*) - -Module Type NAbstract. - -(** The domains: a sequence of [Z/nZ] structures *) - -Parameter dom_t : nat -> Type. -Declare Instance dom_op n : ZnZ.Ops (dom_t n). -Declare Instance dom_spec n : ZnZ.Specs (dom_op n). - -Axiom digits_dom_op : forall n, - ZnZ.digits (dom_op n) = Pos.shiftl_nat (ZnZ.digits (dom_op 0)) n. - -(** The type [t] of arbitrary-large numbers, with abstract constructor [mk_t] - and destructor [destr_t] and iterator [iter_t] *) - -Parameter t : Type. - -Parameter mk_t : forall (n:nat), dom_t n -> t. - -Inductive View_t : t -> Prop := - Mk_t : forall n (x : dom_t n), View_t (mk_t n x). - -Axiom destr_t : forall x, View_t x. (* i.e. every x is a (mk_t n xw) *) - -Parameter iter_t : forall {A:Type}(f : forall n, dom_t n -> A), t -> A. - -Axiom iter_mk_t : forall A (f:forall n, dom_t n -> A), - forall n x, iter_t f (mk_t n x) = f n x. - -(** Conversion to [ZArith] *) - -Parameter to_Z : t -> Z. -Local Notation "[ x ]" := (to_Z x). - -Axiom spec_mk_t : forall n x, [mk_t n x] = ZnZ.to_Z x. - -(** [reduce] is like [mk_t], but try to minimise the level of the number *) - -Parameter reduce : forall (n:nat), dom_t n -> t. -Axiom spec_reduce : forall n x, [reduce n x] = ZnZ.to_Z x. - -(** Number of level in the tree representation of a number. - NB: This function isn't a morphism for setoid [eq]. *) - -Definition level := iter_t (fun n _ => n). - -(** [same_level] and its rich specification, indexed by [level] *) - -Parameter same_level : forall {A:Type} - (f : forall n, dom_t n -> dom_t n -> A), t -> t -> A. - -Axiom spec_same_level_dep : - forall res - (P : nat -> Z -> Z -> res -> Prop) - (Pantimon : forall n m z z' r, (n <= m)%nat -> P m z z' r -> P n z z' r) - (f : forall n, dom_t n -> dom_t n -> res) - (Pf: forall n x y, P n (ZnZ.to_Z x) (ZnZ.to_Z y) (f n x y)), - forall x y, P (level x) [x] [y] (same_level f x y). - -(** [mk_t_S] : building a number of the next level *) - -Parameter mk_t_S : forall (n:nat), zn2z (dom_t n) -> t. - -Axiom spec_mk_t_S : forall n (x:zn2z (dom_t n)), - [mk_t_S n x] = zn2z_to_Z (base (ZnZ.digits (dom_op n))) ZnZ.to_Z x. - -Axiom mk_t_S_level : forall n x, level (mk_t_S n x) = S n. - -End NAbstract. diff --git a/theories/Numbers/Natural/SpecViaZ/NSig.v b/theories/Numbers/Natural/SpecViaZ/NSig.v deleted file mode 100644 index 258e031599..0000000000 --- a/theories/Numbers/Natural/SpecViaZ/NSig.v +++ /dev/null @@ -1,124 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) -(* Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) -(************************************************************************) - -Require Import BinInt. - -Open Scope Z_scope. - -(** * NSig *) - -(** Interface of a rich structure about natural numbers. - Specifications are written via translation to Z. -*) - -Module Type NType. - - Parameter t : Type. - - Parameter to_Z : t -> Z. - Local Notation "[ x ]" := (to_Z x). - Parameter spec_pos: forall x, 0 <= [x]. - - Parameter of_N : N -> t. - Parameter spec_of_N: forall x, to_Z (of_N x) = Z.of_N x. - Definition to_N n := Z.to_N (to_Z n). - - Definition eq n m := [n] = [m]. - Definition lt n m := [n] < [m]. - Definition le n m := [n] <= [m]. - - Parameter compare : t -> t -> comparison. - Parameter eqb : t -> t -> bool. - Parameter ltb : t -> t -> bool. - Parameter leb : t -> t -> bool. - Parameter max : t -> t -> t. - Parameter min : t -> t -> t. - Parameter zero : t. - Parameter one : t. - Parameter two : t. - Parameter succ : t -> t. - Parameter pred : t -> t. - Parameter add : t -> t -> t. - Parameter sub : t -> t -> t. - Parameter mul : t -> t -> t. - Parameter square : t -> t. - Parameter pow_pos : t -> positive -> t. - Parameter pow_N : t -> N -> t. - Parameter pow : t -> t -> t. - Parameter sqrt : t -> t. - Parameter log2 : t -> t. - Parameter div_eucl : t -> t -> t * t. - Parameter div : t -> t -> t. - Parameter modulo : t -> t -> t. - Parameter gcd : t -> t -> t. - Parameter even : t -> bool. - Parameter odd : t -> bool. - Parameter testbit : t -> t -> bool. - Parameter shiftr : t -> t -> t. - Parameter shiftl : t -> t -> t. - Parameter land : t -> t -> t. - Parameter lor : t -> t -> t. - Parameter ldiff : t -> t -> t. - Parameter lxor : t -> t -> t. - Parameter div2 : t -> t. - - Parameter spec_compare: forall x y, compare x y = ([x] ?= [y]). - Parameter spec_eqb : forall x y, eqb x y = ([x] =? [y]). - Parameter spec_ltb : forall x y, ltb x y = ([x] <? [y]). - Parameter spec_leb : forall x y, leb x y = ([x] <=? [y]). - Parameter spec_max : forall x y, [max x y] = Z.max [x] [y]. - Parameter spec_min : forall x y, [min x y] = Z.min [x] [y]. - Parameter spec_0: [zero] = 0. - Parameter spec_1: [one] = 1. - Parameter spec_2: [two] = 2. - Parameter spec_succ: forall n, [succ n] = [n] + 1. - Parameter spec_add: forall x y, [add x y] = [x] + [y]. - Parameter spec_pred: forall x, [pred x] = Z.max 0 ([x] - 1). - Parameter spec_sub: forall x y, [sub x y] = Z.max 0 ([x] - [y]). - Parameter spec_mul: forall x y, [mul x y] = [x] * [y]. - Parameter spec_square: forall x, [square x] = [x] * [x]. - Parameter spec_pow_pos: forall x n, [pow_pos x n] = [x] ^ Zpos n. - Parameter spec_pow_N: forall x n, [pow_N x n] = [x] ^ Z.of_N n. - Parameter spec_pow: forall x n, [pow x n] = [x] ^ [n]. - Parameter spec_sqrt: forall x, [sqrt x] = Z.sqrt [x]. - Parameter spec_log2: forall x, [log2 x] = Z.log2 [x]. - Parameter spec_div_eucl: forall x y, - let (q,r) := div_eucl x y in ([q], [r]) = Z.div_eucl [x] [y]. - Parameter spec_div: forall x y, [div x y] = [x] / [y]. - Parameter spec_modulo: forall x y, [modulo x y] = [x] mod [y]. - Parameter spec_gcd: forall a b, [gcd a b] = Z.gcd [a] [b]. - Parameter spec_even: forall x, even x = Z.even [x]. - Parameter spec_odd: forall x, odd x = Z.odd [x]. - Parameter spec_testbit: forall x p, testbit x p = Z.testbit [x] [p]. - Parameter spec_shiftr: forall x p, [shiftr x p] = Z.shiftr [x] [p]. - Parameter spec_shiftl: forall x p, [shiftl x p] = Z.shiftl [x] [p]. - Parameter spec_land: forall x y, [land x y] = Z.land [x] [y]. - Parameter spec_lor: forall x y, [lor x y] = Z.lor [x] [y]. - Parameter spec_ldiff: forall x y, [ldiff x y] = Z.ldiff [x] [y]. - Parameter spec_lxor: forall x y, [lxor x y] = Z.lxor [x] [y]. - Parameter spec_div2: forall x, [div2 x] = Z.div2 [x]. - -End NType. - -Module Type NType_Notation (Import N:NType). - Notation "[ x ]" := (to_Z x). - Infix "==" := eq (at level 70). - Notation "0" := zero. - Notation "1" := one. - Notation "2" := two. - Infix "+" := add. - Infix "-" := sub. - Infix "*" := mul. - Infix "^" := pow. - Infix "<=" := le. - Infix "<" := lt. -End NType_Notation. - -Module Type NType' := NType <+ NType_Notation. diff --git a/theories/Numbers/Natural/SpecViaZ/NSigNAxioms.v b/theories/Numbers/Natural/SpecViaZ/NSigNAxioms.v deleted file mode 100644 index 355da4cc62..0000000000 --- a/theories/Numbers/Natural/SpecViaZ/NSigNAxioms.v +++ /dev/null @@ -1,487 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -Require Import ZArith OrdersFacts Nnat NAxioms NSig. - -(** * The interface [NSig.NType] implies the interface [NAxiomsSig] *) - -Module NTypeIsNAxioms (Import NN : NType'). - -Hint Rewrite - spec_0 spec_1 spec_2 spec_succ spec_add spec_mul spec_pred spec_sub - spec_div spec_modulo spec_gcd spec_compare spec_eqb spec_ltb spec_leb - spec_square spec_sqrt spec_log2 spec_max spec_min spec_pow_pos spec_pow_N - spec_pow spec_even spec_odd spec_testbit spec_shiftl spec_shiftr - spec_land spec_lor spec_ldiff spec_lxor spec_div2 spec_of_N - : nsimpl. -Ltac nsimpl := autorewrite with nsimpl. -Ltac ncongruence := unfold eq, to_N; repeat red; intros; nsimpl; congruence. -Ltac zify := unfold eq, lt, le, to_N in *; nsimpl. -Ltac omega_pos n := generalize (spec_pos n); omega with *. - -Local Obligation Tactic := ncongruence. - -Instance eq_equiv : Equivalence eq. -Proof. unfold eq. firstorder. Qed. - -Program Instance succ_wd : Proper (eq==>eq) succ. -Program Instance pred_wd : Proper (eq==>eq) pred. -Program Instance add_wd : Proper (eq==>eq==>eq) add. -Program Instance sub_wd : Proper (eq==>eq==>eq) sub. -Program Instance mul_wd : Proper (eq==>eq==>eq) mul. - -Theorem pred_succ : forall n, pred (succ n) == n. -Proof. -intros. zify. omega_pos n. -Qed. - -Theorem one_succ : 1 == succ 0. -Proof. -now zify. -Qed. - -Theorem two_succ : 2 == succ 1. -Proof. -now zify. -Qed. - -Definition N_of_Z z := of_N (Z.to_N z). - -Lemma spec_N_of_Z z : (0<=z)%Z -> [N_of_Z z] = z. -Proof. - unfold N_of_Z. zify. apply Z2N.id. -Qed. - -Section Induction. - -Variable A : NN.t -> Prop. -Hypothesis A_wd : Proper (eq==>iff) A. -Hypothesis A0 : A 0. -Hypothesis AS : forall n, A n <-> A (succ n). - -Let B (z : Z) := A (N_of_Z z). - -Lemma B0 : B 0. -Proof. -unfold B, N_of_Z; simpl. -rewrite <- (A_wd 0); auto. -red; rewrite spec_0, spec_of_N; auto. -Qed. - -Lemma BS : forall z : Z, (0 <= z)%Z -> B z -> B (z + 1). -Proof. -intros z H1 H2. -unfold B in *. apply -> AS in H2. -setoid_replace (N_of_Z (z + 1)) with (succ (N_of_Z z)); auto. -unfold eq. rewrite spec_succ, 2 spec_N_of_Z; auto with zarith. -Qed. - -Lemma B_holds : forall z : Z, (0 <= z)%Z -> B z. -Proof. -exact (natlike_ind B B0 BS). -Qed. - -Theorem bi_induction : forall n, A n. -Proof. -intro n. setoid_replace n with (N_of_Z (to_Z n)). -apply B_holds. apply spec_pos. -red. now rewrite spec_N_of_Z by apply spec_pos. -Qed. - -End Induction. - -Theorem add_0_l : forall n, 0 + n == n. -Proof. -intros. zify. auto with zarith. -Qed. - -Theorem add_succ_l : forall n m, (succ n) + m == succ (n + m). -Proof. -intros. zify. auto with zarith. -Qed. - -Theorem sub_0_r : forall n, n - 0 == n. -Proof. -intros. zify. omega_pos n. -Qed. - -Theorem sub_succ_r : forall n m, n - (succ m) == pred (n - m). -Proof. -intros. zify. omega with *. -Qed. - -Theorem mul_0_l : forall n, 0 * n == 0. -Proof. -intros. zify. auto with zarith. -Qed. - -Theorem mul_succ_l : forall n m, (succ n) * m == n * m + m. -Proof. -intros. zify. ring. -Qed. - -(** Order *) - -Lemma eqb_eq x y : eqb x y = true <-> x == y. -Proof. - zify. apply Z.eqb_eq. -Qed. - -Lemma leb_le x y : leb x y = true <-> x <= y. -Proof. - zify. apply Z.leb_le. -Qed. - -Lemma ltb_lt x y : ltb x y = true <-> x < y. -Proof. - zify. apply Z.ltb_lt. -Qed. - -Lemma compare_eq_iff n m : compare n m = Eq <-> n == m. -Proof. - intros. zify. apply Z.compare_eq_iff. -Qed. - -Lemma compare_lt_iff n m : compare n m = Lt <-> n < m. -Proof. - intros. zify. reflexivity. -Qed. - -Lemma compare_le_iff n m : compare n m <> Gt <-> n <= m. -Proof. - intros. zify. reflexivity. -Qed. - -Lemma compare_antisym n m : compare m n = CompOpp (compare n m). -Proof. - intros. zify. apply Z.compare_antisym. -Qed. - -Include BoolOrderFacts NN NN NN [no inline]. - -Instance compare_wd : Proper (eq ==> eq ==> Logic.eq) compare. -Proof. -intros x x' Hx y y' Hy. zify. now rewrite Hx, Hy. -Qed. - -Instance eqb_wd : Proper (eq ==> eq ==> Logic.eq) eqb. -Proof. -intros x x' Hx y y' Hy. zify. now rewrite Hx, Hy. -Qed. - -Instance ltb_wd : Proper (eq ==> eq ==> Logic.eq) ltb. -Proof. -intros x x' Hx y y' Hy. zify. now rewrite Hx, Hy. -Qed. - -Instance leb_wd : Proper (eq ==> eq ==> Logic.eq) leb. -Proof. -intros x x' Hx y y' Hy. zify. now rewrite Hx, Hy. -Qed. - -Instance lt_wd : Proper (eq ==> eq ==> iff) lt. -Proof. -intros x x' Hx y y' Hy; unfold lt; rewrite Hx, Hy; intuition. -Qed. - -Theorem lt_succ_r : forall n m, n < succ m <-> n <= m. -Proof. -intros. zify. omega. -Qed. - -Theorem min_l : forall n m, n <= m -> min n m == n. -Proof. -intros n m. zify. omega with *. -Qed. - -Theorem min_r : forall n m, m <= n -> min n m == m. -Proof. -intros n m. zify. omega with *. -Qed. - -Theorem max_l : forall n m, m <= n -> max n m == n. -Proof. -intros n m. zify. omega with *. -Qed. - -Theorem max_r : forall n m, n <= m -> max n m == m. -Proof. -intros n m. zify. omega with *. -Qed. - -(** Properties specific to natural numbers, not integers. *) - -Theorem pred_0 : pred 0 == 0. -Proof. -zify. auto. -Qed. - -(** Power *) - -Program Instance pow_wd : Proper (eq==>eq==>eq) pow. - -Lemma pow_0_r : forall a, a^0 == 1. -Proof. - intros. now zify. -Qed. - -Lemma pow_succ_r : forall a b, 0<=b -> a^(succ b) == a * a^b. -Proof. - intros a b. zify. intros. now Z.nzsimpl. -Qed. - -Lemma pow_neg_r : forall a b, b<0 -> a^b == 0. -Proof. - intros a b. zify. intro Hb. exfalso. omega_pos b. -Qed. - -Lemma pow_pow_N : forall a b, a^b == pow_N a (to_N b). -Proof. - intros. zify. f_equal. - now rewrite Z2N.id by apply spec_pos. -Qed. - -Lemma pow_N_pow : forall a b, pow_N a b == a^(of_N b). -Proof. - intros. now zify. -Qed. - -Lemma pow_pos_N : forall a p, pow_pos a p == pow_N a (Npos p). -Proof. - intros. now zify. -Qed. - -(** Square *) - -Lemma square_spec n : square n == n * n. -Proof. - now zify. -Qed. - -(** Sqrt *) - -Lemma sqrt_spec : forall n, 0<=n -> - (sqrt n)*(sqrt n) <= n /\ n < (succ (sqrt n))*(succ (sqrt n)). -Proof. - intros n. zify. apply Z.sqrt_spec. -Qed. - -Lemma sqrt_neg : forall n, n<0 -> sqrt n == 0. -Proof. - intros n. zify. intro H. exfalso. omega_pos n. -Qed. - -(** Log2 *) - -Lemma log2_spec : forall n, 0<n -> - 2^(log2 n) <= n /\ n < 2^(succ (log2 n)). -Proof. - intros n. zify. change (Z.log2 [n]+1)%Z with (Z.succ (Z.log2 [n])). - apply Z.log2_spec. -Qed. - -Lemma log2_nonpos : forall n, n<=0 -> log2 n == 0. -Proof. - intros n. zify. apply Z.log2_nonpos. -Qed. - -(** Even / Odd *) - -Definition Even n := exists m, n == 2*m. -Definition Odd n := exists m, n == 2*m+1. - -Lemma even_spec n : even n = true <-> Even n. -Proof. - unfold Even. zify. rewrite Z.even_spec. - split; intros (m,Hm). - - exists (N_of_Z m). zify. rewrite spec_N_of_Z; trivial. omega_pos n. - - exists [m]. revert Hm; now zify. -Qed. - -Lemma odd_spec n : odd n = true <-> Odd n. -Proof. - unfold Odd. zify. rewrite Z.odd_spec. - split; intros (m,Hm). - - exists (N_of_Z m). zify. rewrite spec_N_of_Z; trivial. omega_pos n. - - exists [m]. revert Hm; now zify. -Qed. - -(** Div / Mod *) - -Program Instance div_wd : Proper (eq==>eq==>eq) div. -Program Instance mod_wd : Proper (eq==>eq==>eq) modulo. - -Theorem div_mod : forall a b, ~b==0 -> a == b*(div a b) + (modulo a b). -Proof. -intros a b. zify. intros. apply Z.div_mod; auto. -Qed. - -Theorem mod_bound_pos : forall a b, 0<=a -> 0<b -> - 0 <= modulo a b /\ modulo a b < b. -Proof. -intros a b. zify. apply Z.mod_bound_pos. -Qed. - -(** Gcd *) - -Definition divide n m := exists p, m == p*n. -Local Notation "( x | y )" := (divide x y) (at level 0). - -Lemma spec_divide : forall n m, (n|m) <-> Z.divide [n] [m]. -Proof. - intros n m. split. - - intros (p,H). exists [p]. revert H; now zify. - - intros (z,H). exists (of_N (Z.abs_N z)). zify. - rewrite N2Z.inj_abs_N. - rewrite <- (Z.abs_eq [m]), <- (Z.abs_eq [n]) by apply spec_pos. - now rewrite H, Z.abs_mul. -Qed. - -Lemma gcd_divide_l : forall n m, (gcd n m | n). -Proof. - intros n m. apply spec_divide. zify. apply Z.gcd_divide_l. -Qed. - -Lemma gcd_divide_r : forall n m, (gcd n m | m). -Proof. - intros n m. apply spec_divide. zify. apply Z.gcd_divide_r. -Qed. - -Lemma gcd_greatest : forall n m p, (p|n) -> (p|m) -> (p|gcd n m). -Proof. - intros n m p. rewrite !spec_divide. zify. apply Z.gcd_greatest. -Qed. - -Lemma gcd_nonneg : forall n m, 0 <= gcd n m. -Proof. - intros. zify. apply Z.gcd_nonneg. -Qed. - -(** Bitwise operations *) - -Program Instance testbit_wd : Proper (eq==>eq==>Logic.eq) testbit. - -Lemma testbit_odd_0 : forall a, testbit (2*a+1) 0 = true. -Proof. - intros. zify. apply Z.testbit_odd_0. -Qed. - -Lemma testbit_even_0 : forall a, testbit (2*a) 0 = false. -Proof. - intros. zify. apply Z.testbit_even_0. -Qed. - -Lemma testbit_odd_succ : forall a n, 0<=n -> - testbit (2*a+1) (succ n) = testbit a n. -Proof. - intros a n. zify. apply Z.testbit_odd_succ. -Qed. - -Lemma testbit_even_succ : forall a n, 0<=n -> - testbit (2*a) (succ n) = testbit a n. -Proof. - intros a n. zify. apply Z.testbit_even_succ. -Qed. - -Lemma testbit_neg_r : forall a n, n<0 -> testbit a n = false. -Proof. - intros a n. zify. apply Z.testbit_neg_r. -Qed. - -Lemma shiftr_spec : forall a n m, 0<=m -> - testbit (shiftr a n) m = testbit a (m+n). -Proof. - intros a n m. zify. apply Z.shiftr_spec. -Qed. - -Lemma shiftl_spec_high : forall a n m, 0<=m -> n<=m -> - testbit (shiftl a n) m = testbit a (m-n). -Proof. - intros a n m. zify. intros Hn H. rewrite Z.max_r by auto with zarith. - now apply Z.shiftl_spec_high. -Qed. - -Lemma shiftl_spec_low : forall a n m, m<n -> - testbit (shiftl a n) m = false. -Proof. - intros a n m. zify. intros H. now apply Z.shiftl_spec_low. -Qed. - -Lemma land_spec : forall a b n, - testbit (land a b) n = testbit a n && testbit b n. -Proof. - intros a n m. zify. now apply Z.land_spec. -Qed. - -Lemma lor_spec : forall a b n, - testbit (lor a b) n = testbit a n || testbit b n. -Proof. - intros a n m. zify. now apply Z.lor_spec. -Qed. - -Lemma ldiff_spec : forall a b n, - testbit (ldiff a b) n = testbit a n && negb (testbit b n). -Proof. - intros a n m. zify. now apply Z.ldiff_spec. -Qed. - -Lemma lxor_spec : forall a b n, - testbit (lxor a b) n = xorb (testbit a n) (testbit b n). -Proof. - intros a n m. zify. now apply Z.lxor_spec. -Qed. - -Lemma div2_spec : forall a, div2 a == shiftr a 1. -Proof. - intros a. zify. now apply Z.div2_spec. -Qed. - -(** Recursion *) - -Definition recursion (A : Type) (a : A) (f : NN.t -> A -> A) (n : NN.t) := - N.peano_rect (fun _ => A) a (fun n a => f (NN.of_N n) a) (NN.to_N n). -Arguments recursion [A] a f n. - -Instance recursion_wd (A : Type) (Aeq : relation A) : - Proper (Aeq ==> (eq==>Aeq==>Aeq) ==> eq ==> Aeq) (@recursion A). -Proof. -unfold eq. -intros a a' Eaa' f f' Eff' x x' Exx'. -unfold recursion. -unfold NN.to_N. -rewrite <- Exx'; clear x' Exx'. -induction (Z.to_N [x]) using N.peano_ind. -simpl; auto. -rewrite 2 N.peano_rect_succ. now apply Eff'. -Qed. - -Theorem recursion_0 : - forall (A : Type) (a : A) (f : NN.t -> A -> A), recursion a f 0 = a. -Proof. -intros A a f; unfold recursion, NN.to_N; rewrite NN.spec_0; simpl; auto. -Qed. - -Theorem recursion_succ : - forall (A : Type) (Aeq : relation A) (a : A) (f : NN.t -> A -> A), - Aeq a a -> Proper (eq==>Aeq==>Aeq) f -> - forall n, Aeq (recursion a f (succ n)) (f n (recursion a f n)). -Proof. -unfold eq, recursion; intros A Aeq a f EAaa f_wd n. -replace (to_N (succ n)) with (N.succ (to_N n)) by - (zify; now rewrite <- Z2N.inj_succ by apply spec_pos). -rewrite N.peano_rect_succ. -apply f_wd; auto. -zify. now rewrite Z2N.id by apply spec_pos. -fold (recursion a f n). apply recursion_wd; auto. red; auto. -Qed. - -End NTypeIsNAxioms. - -Module NType_NAxioms (NN : NType) - <: NAxiomsSig <: OrderFunctions NN <: HasMinMax NN - := NN <+ NTypeIsNAxioms. diff --git a/theories/Numbers/Rational/BigQ/BigQ.v b/theories/Numbers/Rational/BigQ/BigQ.v deleted file mode 100644 index 850afe5345..0000000000 --- a/theories/Numbers/Rational/BigQ/BigQ.v +++ /dev/null @@ -1,162 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(** * BigQ: an efficient implementation of rational numbers *) - -(** Initial authors: Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) - -Require Export BigZ. -Require Import Field Qfield QSig QMake Orders GenericMinMax. - -(** We choose for BigQ an implemention with - multiple representation of 0: 0, 1/0, 2/0 etc. - See [QMake.v] *) - -(** First, we provide translations functions between [BigN] and [BigZ] *) - -Module BigN_BigZ <: NType_ZType BigN.BigN BigZ. - Definition Z_of_N := BigZ.Pos. - Lemma spec_Z_of_N : forall n, BigZ.to_Z (Z_of_N n) = BigN.to_Z n. - Proof. - reflexivity. - Qed. - Definition Zabs_N := BigZ.to_N. - Lemma spec_Zabs_N : forall z, BigN.to_Z (Zabs_N z) = Z.abs (BigZ.to_Z z). - Proof. - unfold Zabs_N; intros. - rewrite BigZ.spec_to_Z, Z.mul_comm; apply Z.sgn_abs. - Qed. -End BigN_BigZ. - -(** This allows building [BigQ] out of [BigN] and [BigQ] via [QMake] *) - -Delimit Scope bigQ_scope with bigQ. - -Module BigQ <: QType <: OrderedTypeFull <: TotalOrder. - Include QMake.Make BigN BigZ BigN_BigZ - <+ !QProperties <+ HasEqBool2Dec - <+ !MinMaxLogicalProperties <+ !MinMaxDecProperties. - Ltac order := Private_Tac.order. -End BigQ. - -(** Notations about [BigQ] *) - -Local Open Scope bigQ_scope. - -Notation bigQ := BigQ.t. -Bind Scope bigQ_scope with bigQ BigQ.t BigQ.t_. -(** As in QArith, we use [#] to denote fractions *) -Notation "p # q" := (BigQ.Qq p q) (at level 55, no associativity) : bigQ_scope. -Local Notation "0" := BigQ.zero : bigQ_scope. -Local Notation "1" := BigQ.one : bigQ_scope. -Infix "+" := BigQ.add : bigQ_scope. -Infix "-" := BigQ.sub : bigQ_scope. -Notation "- x" := (BigQ.opp x) : bigQ_scope. -Infix "*" := BigQ.mul : bigQ_scope. -Infix "/" := BigQ.div : bigQ_scope. -Infix "^" := BigQ.power : bigQ_scope. -Infix "?=" := BigQ.compare : bigQ_scope. -Infix "==" := BigQ.eq : bigQ_scope. -Notation "x != y" := (~x==y) (at level 70, no associativity) : bigQ_scope. -Infix "<" := BigQ.lt : bigQ_scope. -Infix "<=" := BigQ.le : bigQ_scope. -Notation "x > y" := (BigQ.lt y x) (only parsing) : bigQ_scope. -Notation "x >= y" := (BigQ.le y x) (only parsing) : bigQ_scope. -Notation "x < y < z" := (x<y /\ y<z) : bigQ_scope. -Notation "x < y <= z" := (x<y /\ y<=z) : bigQ_scope. -Notation "x <= y < z" := (x<=y /\ y<z) : bigQ_scope. -Notation "x <= y <= z" := (x<=y /\ y<=z) : bigQ_scope. -Notation "[ q ]" := (BigQ.to_Q q) : bigQ_scope. - -(** [BigQ] is a field *) - -Lemma BigQfieldth : - field_theory 0 1 BigQ.add BigQ.mul BigQ.sub BigQ.opp - BigQ.div BigQ.inv BigQ.eq. -Proof. -constructor. -constructor. -exact BigQ.add_0_l. exact BigQ.add_comm. exact BigQ.add_assoc. -exact BigQ.mul_1_l. exact BigQ.mul_comm. exact BigQ.mul_assoc. -exact BigQ.mul_add_distr_r. exact BigQ.sub_add_opp. -exact BigQ.add_opp_diag_r. exact BigQ.neq_1_0. -exact BigQ.div_mul_inv. exact BigQ.mul_inv_diag_l. -Qed. - -Declare Equivalent Keys pow_N pow_pos. - -Lemma BigQpowerth : - power_theory 1 BigQ.mul BigQ.eq Z.of_N BigQ.power. -Proof. -constructor. intros. BigQ.qify. -replace ([r] ^ Z.of_N n)%Q with (pow_N 1 Qmult [r] n)%Q by (now destruct n). -destruct n. reflexivity. -induction p; simpl; auto; rewrite ?BigQ.spec_mul, ?IHp; reflexivity. -Qed. - -Ltac isBigQcst t := - match t with - | BigQ.Qz ?t => isBigZcst t - | BigQ.Qq ?n ?d => match isBigZcst n with - | true => isBigNcst d - | false => constr:(false) - end - | BigQ.zero => constr:(true) - | BigQ.one => constr:(true) - | BigQ.minus_one => constr:(true) - | _ => constr:(false) - end. - -Ltac BigQcst t := - match isBigQcst t with - | true => constr:(t) - | false => constr:(NotConstant) - end. - -Add Field BigQfield : BigQfieldth - (decidable BigQ.eqb_correct, - completeness BigQ.eqb_complete, - constants [BigQcst], - power_tac BigQpowerth [Qpow_tac]). - -Section TestField. - -Let ex1 : forall x y z, (x+y)*z == (x*z)+(y*z). - intros. - ring. -Qed. - -Let ex8 : forall x, x ^ 2 == x*x. - intro. - ring. -Qed. - -Let ex10 : forall x y, y!=0 -> (x/y)*y == x. -intros. -field. -auto. -Qed. - -End TestField. - -(** [BigQ] can also benefit from an "order" tactic *) - -Ltac bigQ_order := BigQ.order. - -Section TestOrder. -Let test : forall x y : bigQ, x<=y -> y<=x -> x==y. -Proof. bigQ_order. Qed. -End TestOrder. - -(** We can also reason by switching to QArith thanks to tactic - BigQ.qify. *) - -Section TestQify. -Let test : forall x : bigQ, 0+x == 1*x. -Proof. intro x. BigQ.qify. ring. Qed. -End TestQify. diff --git a/theories/Numbers/Rational/BigQ/QMake.v b/theories/Numbers/Rational/BigQ/QMake.v deleted file mode 100644 index b9fed9d566..0000000000 --- a/theories/Numbers/Rational/BigQ/QMake.v +++ /dev/null @@ -1,1283 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(** * QMake : a generic efficient implementation of rational numbers *) - -(** Initial authors : Benjamin Gregoire, Laurent Thery, INRIA, 2007 *) - -Require Import BigNumPrelude ROmega. -Require Import QArith Qcanon Qpower Qminmax. -Require Import NSig ZSig QSig. - -(** We will build rationals out of an implementation of integers [ZType] - for numerators and an implementation of natural numbers [NType] for - denominators. But first we will need some glue between [NType] and - [ZType]. *) - -Module Type NType_ZType (NN:NType)(ZZ:ZType). - Parameter Z_of_N : NN.t -> ZZ.t. - Parameter spec_Z_of_N : forall n, ZZ.to_Z (Z_of_N n) = NN.to_Z n. - Parameter Zabs_N : ZZ.t -> NN.t. - Parameter spec_Zabs_N : forall z, NN.to_Z (Zabs_N z) = Z.abs (ZZ.to_Z z). -End NType_ZType. - -Module Make (NN:NType)(ZZ:ZType)(Import NZ:NType_ZType NN ZZ) <: QType. - - (** The notation of a rational number is either an integer x, - interpreted as itself or a pair (x,y) of an integer x and a natural - number y interpreted as x/y. The pairs (x,0) and (0,y) are all - interpreted as 0. *) - - Inductive t_ := - | Qz : ZZ.t -> t_ - | Qq : ZZ.t -> NN.t -> t_. - - Definition t := t_. - - (** Specification with respect to [QArith] *) - - Local Open Scope Q_scope. - - Definition of_Z x: t := Qz (ZZ.of_Z x). - - Definition of_Q (q:Q) : t := - let (x,y) := q in - match y with - | 1%positive => Qz (ZZ.of_Z x) - | _ => Qq (ZZ.of_Z x) (NN.of_N (Npos y)) - end. - - Definition to_Q (q: t) := - match q with - | Qz x => ZZ.to_Z x # 1 - | Qq x y => if NN.eqb y NN.zero then 0 - else ZZ.to_Z x # Z.to_pos (NN.to_Z y) - end. - - Notation "[ x ]" := (to_Q x). - - Lemma N_to_Z_pos : - forall x, (NN.to_Z x <> NN.to_Z NN.zero)%Z -> (0 < NN.to_Z x)%Z. - Proof. - intros x; rewrite NN.spec_0; generalize (NN.spec_pos x). romega. - Qed. - - Ltac destr_zcompare := case Z.compare_spec; intros ?H. - - Ltac destr_eqb := - match goal with - | |- context [ZZ.eqb ?x ?y] => - rewrite (ZZ.spec_eqb x y); - case (Z.eqb_spec (ZZ.to_Z x) (ZZ.to_Z y)); - destr_eqb - | |- context [NN.eqb ?x ?y] => - rewrite (NN.spec_eqb x y); - case (Z.eqb_spec (NN.to_Z x) (NN.to_Z y)); - [ | let H:=fresh "H" in - try (intro H;generalize (N_to_Z_pos _ H); clear H)]; - destr_eqb - | _ => idtac - end. - - Hint Rewrite - Z.add_0_r Z.add_0_l Z.mul_0_r Z.mul_0_l Z.mul_1_r Z.mul_1_l - ZZ.spec_0 NN.spec_0 ZZ.spec_1 NN.spec_1 ZZ.spec_m1 ZZ.spec_opp - ZZ.spec_compare NN.spec_compare - ZZ.spec_add NN.spec_add ZZ.spec_mul NN.spec_mul ZZ.spec_div NN.spec_div - ZZ.spec_gcd NN.spec_gcd Z.gcd_abs_l Z.gcd_1_r - spec_Z_of_N spec_Zabs_N - : nz. - - Ltac nzsimpl := autorewrite with nz in *. - - Ltac qsimpl := try red; unfold to_Q; simpl; intros; - destr_eqb; simpl; nzsimpl; intros; - rewrite ?Z2Pos.id by auto; - auto. - - Theorem strong_spec_of_Q: forall q: Q, [of_Q q] = q. - Proof. - intros(x,y); destruct y; simpl; rewrite ?ZZ.spec_of_Z; auto; - destr_eqb; now rewrite ?NN.spec_0, ?NN.spec_of_N. - Qed. - - Theorem spec_of_Q: forall q: Q, [of_Q q] == q. - Proof. - intros; rewrite strong_spec_of_Q; red; auto. - Qed. - - Definition eq x y := [x] == [y]. - - Definition zero: t := Qz ZZ.zero. - Definition one: t := Qz ZZ.one. - Definition minus_one: t := Qz ZZ.minus_one. - - Lemma spec_0: [zero] == 0. - Proof. - simpl. nzsimpl. reflexivity. - Qed. - - Lemma spec_1: [one] == 1. - Proof. - simpl. nzsimpl. reflexivity. - Qed. - - Lemma spec_m1: [minus_one] == -(1). - Proof. - simpl. nzsimpl. reflexivity. - Qed. - - Definition compare (x y: t) := - match x, y with - | Qz zx, Qz zy => ZZ.compare zx zy - | Qz zx, Qq ny dy => - if NN.eqb dy NN.zero then ZZ.compare zx ZZ.zero - else ZZ.compare (ZZ.mul zx (Z_of_N dy)) ny - | Qq nx dx, Qz zy => - if NN.eqb dx NN.zero then ZZ.compare ZZ.zero zy - else ZZ.compare nx (ZZ.mul zy (Z_of_N dx)) - | Qq nx dx, Qq ny dy => - match NN.eqb dx NN.zero, NN.eqb dy NN.zero with - | true, true => Eq - | true, false => ZZ.compare ZZ.zero ny - | false, true => ZZ.compare nx ZZ.zero - | false, false => ZZ.compare (ZZ.mul nx (Z_of_N dy)) - (ZZ.mul ny (Z_of_N dx)) - end - end. - - Theorem spec_compare: forall q1 q2, (compare q1 q2) = ([q1] ?= [q2]). - Proof. - intros [z1 | x1 y1] [z2 | x2 y2]; - unfold Qcompare, compare; qsimpl. - Qed. - - Definition lt n m := [n] < [m]. - Definition le n m := [n] <= [m]. - - Definition min n m := match compare n m with Gt => m | _ => n end. - Definition max n m := match compare n m with Lt => m | _ => n end. - - Lemma spec_min : forall n m, [min n m] == Qmin [n] [m]. - Proof. - unfold min, Qmin, GenericMinMax.gmin. intros. - rewrite spec_compare; destruct Qcompare; auto with qarith. - Qed. - - Lemma spec_max : forall n m, [max n m] == Qmax [n] [m]. - Proof. - unfold max, Qmax, GenericMinMax.gmax. intros. - rewrite spec_compare; destruct Qcompare; auto with qarith. - Qed. - - Definition eq_bool n m := - match compare n m with Eq => true | _ => false end. - - Theorem spec_eq_bool: forall x y, eq_bool x y = Qeq_bool [x] [y]. - Proof. - intros. unfold eq_bool. rewrite spec_compare. reflexivity. - Qed. - - (** [check_int] : is a reduced fraction [n/d] in fact a integer ? *) - - Definition check_int n d := - match NN.compare NN.one d with - | Lt => Qq n d - | Eq => Qz n - | Gt => zero (* n/0 encodes 0 *) - end. - - Theorem strong_spec_check_int : forall n d, [check_int n d] = [Qq n d]. - Proof. - intros; unfold check_int. - nzsimpl. - destr_zcompare. - simpl. rewrite <- H; qsimpl. congruence. - reflexivity. - qsimpl. exfalso; romega. - Qed. - - (** Normalisation function *) - - Definition norm n d : t := - let gcd := NN.gcd (Zabs_N n) d in - match NN.compare NN.one gcd with - | Lt => check_int (ZZ.div n (Z_of_N gcd)) (NN.div d gcd) - | Eq => check_int n d - | Gt => zero (* gcd = 0 => both numbers are 0 *) - end. - - Theorem spec_norm: forall n q, [norm n q] == [Qq n q]. - Proof. - intros p q; unfold norm. - assert (Hp := NN.spec_pos (Zabs_N p)). - assert (Hq := NN.spec_pos q). - nzsimpl. - destr_zcompare. - (* Eq *) - rewrite strong_spec_check_int; reflexivity. - (* Lt *) - rewrite strong_spec_check_int. - qsimpl. - generalize (Zgcd_div_pos (ZZ.to_Z p) (NN.to_Z q)). romega. - replace (NN.to_Z q) with 0%Z in * by assumption. - rewrite Zdiv_0_l in *; auto with zarith. - apply Zgcd_div_swap0; romega. - (* Gt *) - qsimpl. - assert (H' : Z.gcd (ZZ.to_Z p) (NN.to_Z q) = 0%Z). - generalize (Z.gcd_nonneg (ZZ.to_Z p) (NN.to_Z q)); romega. - symmetry; apply (Z.gcd_eq_0_l _ _ H'); auto. - Qed. - - Theorem strong_spec_norm : forall p q, [norm p q] = Qred [Qq p q]. - Proof. - intros. - replace (Qred [Qq p q]) with (Qred [norm p q]) by - (apply Qred_complete; apply spec_norm). - symmetry; apply Qred_identity. - unfold norm. - assert (Hp := NN.spec_pos (Zabs_N p)). - assert (Hq := NN.spec_pos q). - nzsimpl. - destr_zcompare; rewrite ?strong_spec_check_int. - (* Eq *) - qsimpl. - (* Lt *) - qsimpl. - rewrite Zgcd_1_rel_prime. - destruct (Z_lt_le_dec 0 (NN.to_Z q)). - apply Zis_gcd_rel_prime; auto with zarith. - apply Zgcd_is_gcd. - replace (NN.to_Z q) with 0%Z in * by romega. - rewrite Zdiv_0_l in *; romega. - (* Gt *) - simpl; auto with zarith. - Qed. - - (** Reduction function : producing irreducible fractions *) - - Definition red (x : t) : t := - match x with - | Qz z => x - | Qq n d => norm n d - end. - - Class Reduced x := is_reduced : [red x] = [x]. - - Theorem spec_red : forall x, [red x] == [x]. - Proof. - intros [ z | n d ]. - auto with qarith. - unfold red. - apply spec_norm. - Qed. - - Theorem strong_spec_red : forall x, [red x] = Qred [x]. - Proof. - intros [ z | n d ]. - unfold red. - symmetry; apply Qred_identity; simpl; auto with zarith. - unfold red; apply strong_spec_norm. - Qed. - - Definition add (x y: t): t := - match x with - | Qz zx => - match y with - | Qz zy => Qz (ZZ.add zx zy) - | Qq ny dy => - if NN.eqb dy NN.zero then x - else Qq (ZZ.add (ZZ.mul zx (Z_of_N dy)) ny) dy - end - | Qq nx dx => - if NN.eqb dx NN.zero then y - else match y with - | Qz zy => Qq (ZZ.add nx (ZZ.mul zy (Z_of_N dx))) dx - | Qq ny dy => - if NN.eqb dy NN.zero then x - else - let n := ZZ.add (ZZ.mul nx (Z_of_N dy)) (ZZ.mul ny (Z_of_N dx)) in - let d := NN.mul dx dy in - Qq n d - end - end. - - Theorem spec_add : forall x y, [add x y] == [x] + [y]. - Proof. - intros [x | nx dx] [y | ny dy]; unfold Qplus; qsimpl; - auto with zarith. - rewrite Pos.mul_1_r, Z2Pos.id; auto. - rewrite Pos.mul_1_r, Z2Pos.id; auto. - rewrite Z.mul_eq_0 in *; intuition. - rewrite Pos2Z.inj_mul, 2 Z2Pos.id; auto. - Qed. - - Definition add_norm (x y: t): t := - match x with - | Qz zx => - match y with - | Qz zy => Qz (ZZ.add zx zy) - | Qq ny dy => - if NN.eqb dy NN.zero then x - else norm (ZZ.add (ZZ.mul zx (Z_of_N dy)) ny) dy - end - | Qq nx dx => - if NN.eqb dx NN.zero then y - else match y with - | Qz zy => norm (ZZ.add nx (ZZ.mul zy (Z_of_N dx))) dx - | Qq ny dy => - if NN.eqb dy NN.zero then x - else - let n := ZZ.add (ZZ.mul nx (Z_of_N dy)) (ZZ.mul ny (Z_of_N dx)) in - let d := NN.mul dx dy in - norm n d - end - end. - - Theorem spec_add_norm : forall x y, [add_norm x y] == [x] + [y]. - Proof. - intros x y; rewrite <- spec_add. - destruct x; destruct y; unfold add_norm, add; - destr_eqb; auto using Qeq_refl, spec_norm. - Qed. - - Instance strong_spec_add_norm x y - `(Reduced x, Reduced y) : Reduced (add_norm x y). - Proof. - unfold Reduced; intros. - rewrite strong_spec_red. - rewrite <- (Qred_complete [add x y]); - [ | rewrite spec_add, spec_add_norm; apply Qeq_refl ]. - rewrite <- strong_spec_red. - destruct x as [zx|nx dx]; destruct y as [zy|ny dy]; - simpl; destr_eqb; nzsimpl; simpl; auto. - Qed. - - Definition opp (x: t): t := - match x with - | Qz zx => Qz (ZZ.opp zx) - | Qq nx dx => Qq (ZZ.opp nx) dx - end. - - Theorem strong_spec_opp: forall q, [opp q] = -[q]. - Proof. - intros [z | x y]; simpl. - rewrite ZZ.spec_opp; auto. - match goal with |- context[NN.eqb ?X ?Y] => - generalize (NN.spec_eqb X Y); case NN.eqb - end; auto; rewrite NN.spec_0. - rewrite ZZ.spec_opp; auto. - Qed. - - Theorem spec_opp : forall q, [opp q] == -[q]. - Proof. - intros; rewrite strong_spec_opp; red; auto. - Qed. - - Instance strong_spec_opp_norm q `(Reduced q) : Reduced (opp q). - Proof. - unfold Reduced; intros. - rewrite strong_spec_opp, <- H, !strong_spec_red, <- Qred_opp. - apply Qred_complete; apply spec_opp. - Qed. - - Definition sub x y := add x (opp y). - - Theorem spec_sub : forall x y, [sub x y] == [x] - [y]. - Proof. - intros x y; unfold sub; rewrite spec_add; auto. - rewrite spec_opp; ring. - Qed. - - Definition sub_norm x y := add_norm x (opp y). - - Theorem spec_sub_norm : forall x y, [sub_norm x y] == [x] - [y]. - Proof. - intros x y; unfold sub_norm; rewrite spec_add_norm; auto. - rewrite spec_opp; ring. - Qed. - - Instance strong_spec_sub_norm x y - `(Reduced x, Reduced y) : Reduced (sub_norm x y). - Proof. - intros. - unfold sub_norm. - apply strong_spec_add_norm; auto. - apply strong_spec_opp_norm; auto. - Qed. - - Definition mul (x y: t): t := - match x, y with - | Qz zx, Qz zy => Qz (ZZ.mul zx zy) - | Qz zx, Qq ny dy => Qq (ZZ.mul zx ny) dy - | Qq nx dx, Qz zy => Qq (ZZ.mul nx zy) dx - | Qq nx dx, Qq ny dy => Qq (ZZ.mul nx ny) (NN.mul dx dy) - end. - - Ltac nsubst := - match goal with E : NN.to_Z _ = _ |- _ => rewrite E in * end. - - Theorem spec_mul : forall x y, [mul x y] == [x] * [y]. - Proof. - intros [x | nx dx] [y | ny dy]; unfold Qmult; simpl; qsimpl. - rewrite Pos.mul_1_r, Z2Pos.id; auto. - rewrite Z.mul_eq_0 in *; intuition. - nsubst; auto with zarith. - nsubst; auto with zarith. - nsubst; nzsimpl; auto with zarith. - rewrite Pos2Z.inj_mul, 2 Z2Pos.id; auto. - Qed. - - Definition norm_denum n d := - if NN.eqb d NN.one then Qz n else Qq n d. - - Lemma spec_norm_denum : forall n d, - [norm_denum n d] == [Qq n d]. - Proof. - unfold norm_denum; intros; simpl; qsimpl. - congruence. - nsubst; auto with zarith. - Qed. - - Definition irred n d := - let gcd := NN.gcd (Zabs_N n) d in - match NN.compare gcd NN.one with - | Gt => (ZZ.div n (Z_of_N gcd), NN.div d gcd) - | _ => (n, d) - end. - - Lemma spec_irred : forall n d, exists g, - let (n',d') := irred n d in - (ZZ.to_Z n' * g = ZZ.to_Z n)%Z /\ (NN.to_Z d' * g = NN.to_Z d)%Z. - Proof. - intros. - unfold irred; nzsimpl; simpl. - destr_zcompare. - exists 1%Z; nzsimpl; auto. - exists 0%Z; nzsimpl. - assert (Z.gcd (ZZ.to_Z n) (NN.to_Z d) = 0%Z). - generalize (Z.gcd_nonneg (ZZ.to_Z n) (NN.to_Z d)); romega. - clear H. - split. - symmetry; apply (Z.gcd_eq_0_l _ _ H0). - symmetry; apply (Z.gcd_eq_0_r _ _ H0). - exists (Z.gcd (ZZ.to_Z n) (NN.to_Z d)). - simpl. - split. - nzsimpl. - destruct (Zgcd_is_gcd (ZZ.to_Z n) (NN.to_Z d)). - rewrite Z.mul_comm; symmetry; apply Zdivide_Zdiv_eq; auto with zarith. - nzsimpl. - destruct (Zgcd_is_gcd (ZZ.to_Z n) (NN.to_Z d)). - rewrite Z.mul_comm; symmetry; apply Zdivide_Zdiv_eq; auto with zarith. - Qed. - - Lemma spec_irred_zero : forall n d, - (NN.to_Z d = 0)%Z <-> (NN.to_Z (snd (irred n d)) = 0)%Z. - Proof. - intros. - unfold irred. - split. - nzsimpl; intros. - destr_zcompare; auto. - simpl. - nzsimpl. - rewrite H, Zdiv_0_l; auto. - nzsimpl; destr_zcompare; simpl; auto. - nzsimpl. - intros. - generalize (NN.spec_pos d); intros. - destruct (NN.to_Z d); auto. - assert (0 < 0)%Z. - rewrite <- H0 at 2. - apply Zgcd_div_pos; auto with zarith. - compute; auto. - discriminate. - compute in H1; elim H1; auto. - Qed. - - Lemma strong_spec_irred : forall n d, - (NN.to_Z d <> 0%Z) -> - let (n',d') := irred n d in Z.gcd (ZZ.to_Z n') (NN.to_Z d') = 1%Z. - Proof. - unfold irred; intros. - nzsimpl. - destr_zcompare; simpl; auto. - elim H. - apply (Z.gcd_eq_0_r (ZZ.to_Z n)). - generalize (Z.gcd_nonneg (ZZ.to_Z n) (NN.to_Z d)); romega. - - nzsimpl. - rewrite Zgcd_1_rel_prime. - apply Zis_gcd_rel_prime. - generalize (NN.spec_pos d); romega. - generalize (Z.gcd_nonneg (ZZ.to_Z n) (NN.to_Z d)); romega. - apply Zgcd_is_gcd; auto. - Qed. - - Definition mul_norm_Qz_Qq z n d := - if ZZ.eqb z ZZ.zero then zero - else - let gcd := NN.gcd (Zabs_N z) d in - match NN.compare gcd NN.one with - | Gt => - let z := ZZ.div z (Z_of_N gcd) in - let d := NN.div d gcd in - norm_denum (ZZ.mul z n) d - | _ => Qq (ZZ.mul z n) d - end. - - Definition mul_norm (x y: t): t := - match x, y with - | Qz zx, Qz zy => Qz (ZZ.mul zx zy) - | Qz zx, Qq ny dy => mul_norm_Qz_Qq zx ny dy - | Qq nx dx, Qz zy => mul_norm_Qz_Qq zy nx dx - | Qq nx dx, Qq ny dy => - let (nx, dy) := irred nx dy in - let (ny, dx) := irred ny dx in - norm_denum (ZZ.mul ny nx) (NN.mul dx dy) - end. - - Lemma spec_mul_norm_Qz_Qq : forall z n d, - [mul_norm_Qz_Qq z n d] == [Qq (ZZ.mul z n) d]. - Proof. - intros z n d; unfold mul_norm_Qz_Qq; nzsimpl; rewrite Zcompare_gt. - destr_eqb; nzsimpl; intros Hz. - qsimpl; rewrite Hz; auto. - destruct Z_le_gt_dec as [LE|GT]. - qsimpl. - rewrite spec_norm_denum. - qsimpl. - rewrite Zdiv_gcd_zero in GT; auto with zarith. - nsubst. rewrite Zdiv_0_l in *; discriminate. - rewrite <- Z.mul_assoc, (Z.mul_comm (ZZ.to_Z n)), Z.mul_assoc. - rewrite Zgcd_div_swap0; try romega. - ring. - Qed. - - Instance strong_spec_mul_norm_Qz_Qq z n d : - forall `(Reduced (Qq n d)), Reduced (mul_norm_Qz_Qq z n d). - Proof. - unfold Reduced. - rewrite 2 strong_spec_red, 2 Qred_iff. - simpl; nzsimpl. - destr_eqb; intros Hd H; simpl in *; nzsimpl. - - unfold mul_norm_Qz_Qq; nzsimpl; rewrite Zcompare_gt. - destr_eqb; intros Hz; simpl; nzsimpl; simpl; auto. - destruct Z_le_gt_dec. - simpl; nzsimpl. - destr_eqb; simpl; nzsimpl; auto with zarith. - unfold norm_denum. destr_eqb; simpl; nzsimpl. - rewrite Hd, Zdiv_0_l; discriminate. - intros _. - destr_eqb; simpl; nzsimpl; auto. - nzsimpl; rewrite Hd, Zdiv_0_l; auto with zarith. - - rewrite Z2Pos.id in H; auto. - unfold mul_norm_Qz_Qq; nzsimpl; rewrite Zcompare_gt. - destr_eqb; intros Hz; simpl; nzsimpl; simpl; auto. - destruct Z_le_gt_dec as [H'|H']. - simpl; nzsimpl. - destr_eqb; simpl; nzsimpl; auto. - intros. - rewrite Z2Pos.id; auto. - apply Zgcd_mult_rel_prime; auto. - generalize (Z.gcd_eq_0_l (ZZ.to_Z z) (NN.to_Z d)) - (Z.gcd_nonneg (ZZ.to_Z z) (NN.to_Z d)); romega. - destr_eqb; simpl; nzsimpl; auto. - unfold norm_denum. - destr_eqb; nzsimpl; simpl; destr_eqb; simpl; auto. - intros; nzsimpl. - rewrite Z2Pos.id; auto. - apply Zgcd_mult_rel_prime. - rewrite Zgcd_1_rel_prime. - apply Zis_gcd_rel_prime. - generalize (NN.spec_pos d); romega. - generalize (Z.gcd_nonneg (ZZ.to_Z z) (NN.to_Z d)); romega. - apply Zgcd_is_gcd. - destruct (Zgcd_is_gcd (ZZ.to_Z z) (NN.to_Z d)) as [ (z0,Hz0) (d0,Hd0) Hzd]. - replace (NN.to_Z d / Z.gcd (ZZ.to_Z z) (NN.to_Z d))%Z with d0. - rewrite Zgcd_1_rel_prime in *. - apply bezout_rel_prime. - destruct (rel_prime_bezout _ _ H) as [u v Huv]. - apply Bezout_intro with u (v*(Z.gcd (ZZ.to_Z z) (NN.to_Z d)))%Z. - rewrite <- Huv; rewrite Hd0 at 2; ring. - rewrite Hd0 at 1. - symmetry; apply Z_div_mult_full; auto with zarith. - Qed. - - Theorem spec_mul_norm : forall x y, [mul_norm x y] == [x] * [y]. - Proof. - intros x y; rewrite <- spec_mul; auto. - unfold mul_norm, mul; destruct x; destruct y. - apply Qeq_refl. - apply spec_mul_norm_Qz_Qq. - rewrite spec_mul_norm_Qz_Qq; qsimpl; ring. - - rename t0 into nx, t3 into dy, t2 into ny, t1 into dx. - destruct (spec_irred nx dy) as (g & Hg). - destruct (spec_irred ny dx) as (g' & Hg'). - assert (Hz := spec_irred_zero nx dy). - assert (Hz':= spec_irred_zero ny dx). - destruct irred as (n1,d1); destruct irred as (n2,d2). - simpl @snd in *; destruct Hg as [Hg1 Hg2]; destruct Hg' as [Hg1' Hg2']. - rewrite spec_norm_denum. - qsimpl. - - match goal with E : (_ * _ = 0)%Z |- _ => - rewrite Z.mul_eq_0 in E; destruct E as [Eq|Eq] end. - rewrite Eq in *; simpl in *. - rewrite <- Hg2' in *; auto with zarith. - rewrite Eq in *; simpl in *. - rewrite <- Hg2 in *; auto with zarith. - - match goal with E : (_ * _ = 0)%Z |- _ => - rewrite Z.mul_eq_0 in E; destruct E as [Eq|Eq] end. - rewrite Hz' in Eq; rewrite Eq in *; auto with zarith. - rewrite Hz in Eq; rewrite Eq in *; auto with zarith. - - rewrite <- Hg1, <- Hg2, <- Hg1', <- Hg2'; ring. - Qed. - - Instance strong_spec_mul_norm x y : - forall `(Reduced x, Reduced y), Reduced (mul_norm x y). - Proof. - unfold Reduced; intros. - rewrite strong_spec_red, Qred_iff. - destruct x as [zx|nx dx]; destruct y as [zy|ny dy]. - simpl in *; auto with zarith. - simpl. - rewrite <- Qred_iff, <- strong_spec_red, strong_spec_mul_norm_Qz_Qq; auto. - simpl. - rewrite <- Qred_iff, <- strong_spec_red, strong_spec_mul_norm_Qz_Qq; auto. - simpl. - destruct (spec_irred nx dy) as [g Hg]. - destruct (spec_irred ny dx) as [g' Hg']. - assert (Hz := spec_irred_zero nx dy). - assert (Hz':= spec_irred_zero ny dx). - assert (Hgc := strong_spec_irred nx dy). - assert (Hgc' := strong_spec_irred ny dx). - destruct irred as (n1,d1); destruct irred as (n2,d2). - simpl @snd in *; destruct Hg as [Hg1 Hg2]; destruct Hg' as [Hg1' Hg2']. - - unfold norm_denum; qsimpl. - - assert (NEQ : NN.to_Z dy <> 0%Z) by - (rewrite Hz; intros EQ; rewrite EQ in *; romega). - specialize (Hgc NEQ). - - assert (NEQ' : NN.to_Z dx <> 0%Z) by - (rewrite Hz'; intro EQ; rewrite EQ in *; romega). - specialize (Hgc' NEQ'). - - revert H H0. - rewrite 2 strong_spec_red, 2 Qred_iff; simpl. - destr_eqb; simpl; nzsimpl; try romega; intros. - rewrite Z2Pos.id in *; auto. - - apply Zgcd_mult_rel_prime; rewrite Z.gcd_comm; - apply Zgcd_mult_rel_prime; rewrite Z.gcd_comm; auto. - - rewrite Zgcd_1_rel_prime in *. - apply bezout_rel_prime. - destruct (rel_prime_bezout (ZZ.to_Z ny) (NN.to_Z dy)) as [u v Huv]; trivial. - apply Bezout_intro with (u*g')%Z (v*g)%Z. - rewrite <- Huv, <- Hg1', <- Hg2. ring. - - rewrite Zgcd_1_rel_prime in *. - apply bezout_rel_prime. - destruct (rel_prime_bezout (ZZ.to_Z nx) (NN.to_Z dx)) as [u v Huv]; trivial. - apply Bezout_intro with (u*g)%Z (v*g')%Z. - rewrite <- Huv, <- Hg2', <- Hg1. ring. - Qed. - - Definition inv (x: t): t := - match x with - | Qz z => - match ZZ.compare ZZ.zero z with - | Eq => zero - | Lt => Qq ZZ.one (Zabs_N z) - | Gt => Qq ZZ.minus_one (Zabs_N z) - end - | Qq n d => - match ZZ.compare ZZ.zero n with - | Eq => zero - | Lt => Qq (Z_of_N d) (Zabs_N n) - | Gt => Qq (ZZ.opp (Z_of_N d)) (Zabs_N n) - end - end. - - Theorem spec_inv : forall x, [inv x] == /[x]. - Proof. - destruct x as [ z | n d ]. - (* Qz z *) - simpl. - rewrite ZZ.spec_compare; destr_zcompare. - (* 0 = z *) - rewrite <- H. - simpl; nzsimpl; compute; auto. - (* 0 < z *) - simpl. - destr_eqb; nzsimpl; [ intros; rewrite Z.abs_eq in *; romega | intros _ ]. - set (z':=ZZ.to_Z z) in *; clearbody z'. - red; simpl. - rewrite Z.abs_eq by romega. - rewrite Z2Pos.id by auto. - unfold Qinv; simpl; destruct z'; simpl; auto; discriminate. - (* 0 > z *) - simpl. - destr_eqb; nzsimpl; [ intros; rewrite Z.abs_neq in *; romega | intros _ ]. - set (z':=ZZ.to_Z z) in *; clearbody z'. - red; simpl. - rewrite Z.abs_neq by romega. - rewrite Z2Pos.id by romega. - unfold Qinv; simpl; destruct z'; simpl; auto; discriminate. - (* Qq n d *) - simpl. - rewrite ZZ.spec_compare; destr_zcompare. - (* 0 = n *) - rewrite <- H. - simpl; nzsimpl. - destr_eqb; intros; compute; auto. - (* 0 < n *) - simpl. - destr_eqb; nzsimpl; intros. - intros; rewrite Z.abs_eq in *; romega. - intros; rewrite Z.abs_eq in *; romega. - nsubst; compute; auto. - set (n':=ZZ.to_Z n) in *; clearbody n'. - rewrite Z.abs_eq by romega. - red; simpl. - rewrite Z2Pos.id by auto. - unfold Qinv; simpl; destruct n'; simpl; auto; try discriminate. - rewrite Pos2Z.inj_mul, Z2Pos.id; auto. - (* 0 > n *) - simpl. - destr_eqb; nzsimpl; intros. - intros; rewrite Z.abs_neq in *; romega. - intros; rewrite Z.abs_neq in *; romega. - nsubst; compute; auto. - set (n':=ZZ.to_Z n) in *; clearbody n'. - red; simpl; nzsimpl. - rewrite Z.abs_neq by romega. - rewrite Z2Pos.id by romega. - unfold Qinv; simpl; destruct n'; simpl; auto; try discriminate. - assert (T : forall x, Zneg x = Z.opp (Zpos x)) by auto. - rewrite T, Pos2Z.inj_mul, Z2Pos.id; auto; ring. - Qed. - - Definition inv_norm (x: t): t := - match x with - | Qz z => - match ZZ.compare ZZ.zero z with - | Eq => zero - | Lt => Qq ZZ.one (Zabs_N z) - | Gt => Qq ZZ.minus_one (Zabs_N z) - end - | Qq n d => - if NN.eqb d NN.zero then zero else - match ZZ.compare ZZ.zero n with - | Eq => zero - | Lt => - match ZZ.compare n ZZ.one with - | Gt => Qq (Z_of_N d) (Zabs_N n) - | _ => Qz (Z_of_N d) - end - | Gt => - match ZZ.compare n ZZ.minus_one with - | Lt => Qq (ZZ.opp (Z_of_N d)) (Zabs_N n) - | _ => Qz (ZZ.opp (Z_of_N d)) - end - end - end. - - Theorem spec_inv_norm : forall x, [inv_norm x] == /[x]. - Proof. - intros. - rewrite <- spec_inv. - destruct x as [ z | n d ]. - (* Qz z *) - simpl. - rewrite ZZ.spec_compare; destr_zcompare; auto with qarith. - (* Qq n d *) - simpl; nzsimpl; destr_eqb. - destr_zcompare; simpl; auto with qarith. - destr_eqb; nzsimpl; auto with qarith. - intros _ Hd; rewrite Hd; auto with qarith. - destr_eqb; nzsimpl; auto with qarith. - intros _ Hd; rewrite Hd; auto with qarith. - (* 0 < n *) - destr_zcompare; auto with qarith. - destr_zcompare; nzsimpl; simpl; auto with qarith; intros. - destr_eqb; nzsimpl; [ intros; rewrite Z.abs_eq in *; romega | intros _ ]. - rewrite H0; auto with qarith. - romega. - (* 0 > n *) - destr_zcompare; nzsimpl; simpl; auto with qarith. - destr_eqb; nzsimpl; [ intros; rewrite Z.abs_neq in *; romega | intros _ ]. - rewrite H0; auto with qarith. - romega. - Qed. - - Instance strong_spec_inv_norm x : Reduced x -> Reduced (inv_norm x). - Proof. - unfold Reduced. - intros. - destruct x as [ z | n d ]. - (* Qz *) - simpl; nzsimpl. - rewrite strong_spec_red, Qred_iff. - destr_zcompare; simpl; nzsimpl; auto. - destr_eqb; nzsimpl; simpl; auto. - destr_eqb; nzsimpl; simpl; auto. - (* Qq n d *) - rewrite strong_spec_red, Qred_iff in H; revert H. - simpl; nzsimpl. - destr_eqb; nzsimpl; auto with qarith. - destr_zcompare; simpl; nzsimpl; auto; intros. - (* 0 < n *) - destr_zcompare; simpl; nzsimpl; auto. - destr_eqb; nzsimpl; simpl; auto. - rewrite Z.abs_eq; romega. - intros _. - rewrite strong_spec_norm; simpl; nzsimpl. - destr_eqb; nzsimpl. - rewrite Z.abs_eq; romega. - intros _. - rewrite Qred_iff. - simpl. - rewrite Z.abs_eq; auto with zarith. - rewrite Z2Pos.id in *; auto. - rewrite Z.gcd_comm; auto. - (* 0 > n *) - destr_eqb; nzsimpl; simpl; auto; intros. - destr_zcompare; simpl; nzsimpl; auto. - destr_eqb; nzsimpl. - rewrite Z.abs_neq; romega. - intros _. - rewrite strong_spec_norm; simpl; nzsimpl. - destr_eqb; nzsimpl. - rewrite Z.abs_neq; romega. - intros _. - rewrite Qred_iff. - simpl. - rewrite Z2Pos.id in *; auto. - intros. - rewrite Z.gcd_comm, Z.gcd_abs_l, Z.gcd_comm. - apply Zis_gcd_gcd; auto with zarith. - apply Zis_gcd_minus. - rewrite Z.opp_involutive, <- H1; apply Zgcd_is_gcd. - rewrite Z.abs_neq; romega. - Qed. - - Definition div x y := mul x (inv y). - - Theorem spec_div x y: [div x y] == [x] / [y]. - Proof. - unfold div; rewrite spec_mul; auto. - unfold Qdiv; apply Qmult_comp. - apply Qeq_refl. - apply spec_inv; auto. - Qed. - - Definition div_norm x y := mul_norm x (inv_norm y). - - Theorem spec_div_norm x y: [div_norm x y] == [x] / [y]. - Proof. - unfold div_norm; rewrite spec_mul_norm; auto. - unfold Qdiv; apply Qmult_comp. - apply Qeq_refl. - apply spec_inv_norm; auto. - Qed. - - Instance strong_spec_div_norm x y - `(Reduced x, Reduced y) : Reduced (div_norm x y). - Proof. - intros; unfold div_norm. - apply strong_spec_mul_norm; auto. - apply strong_spec_inv_norm; auto. - Qed. - - Definition square (x: t): t := - match x with - | Qz zx => Qz (ZZ.square zx) - | Qq nx dx => Qq (ZZ.square nx) (NN.square dx) - end. - - Theorem spec_square : forall x, [square x] == [x] ^ 2. - Proof. - destruct x as [ z | n d ]. - simpl; rewrite ZZ.spec_square; red; auto. - simpl. - destr_eqb; nzsimpl; intros. - apply Qeq_refl. - rewrite NN.spec_square in *; nzsimpl. - rewrite Z.mul_eq_0 in *; romega. - rewrite NN.spec_square in *; nzsimpl; nsubst; romega. - rewrite ZZ.spec_square, NN.spec_square. - red; simpl. - rewrite Pos2Z.inj_mul; rewrite !Z2Pos.id; auto. - apply Z.mul_pos_pos; auto. - Qed. - - Definition power_pos (x : t) p : t := - match x with - | Qz zx => Qz (ZZ.pow_pos zx p) - | Qq nx dx => Qq (ZZ.pow_pos nx p) (NN.pow_pos dx p) - end. - - Theorem spec_power_pos : forall x p, [power_pos x p] == [x] ^ Zpos p. - Proof. - intros [ z | n d ] p; unfold power_pos. - (* Qz *) - simpl. - rewrite ZZ.spec_pow_pos, Qpower_decomp. - red; simpl; f_equal. - now rewrite Pos2Z.inj_pow, Z.pow_1_l. - (* Qq *) - simpl. - rewrite ZZ.spec_pow_pos. - destr_eqb; nzsimpl; intros. - - apply Qeq_sym; apply Qpower_positive_0. - - rewrite NN.spec_pow_pos in *. - assert (0 < NN.to_Z d ^ ' p)%Z by - (apply Z.pow_pos_nonneg; auto with zarith). - romega. - - exfalso. - rewrite NN.spec_pow_pos in *. nsubst. - rewrite Z.pow_0_l' in *; [romega|discriminate]. - - rewrite Qpower_decomp. - red; simpl; do 3 f_equal. - apply Pos2Z.inj. rewrite Pos2Z.inj_pow. - rewrite 2 Z2Pos.id by (generalize (NN.spec_pos d); romega). - now rewrite NN.spec_pow_pos. - Qed. - - Instance strong_spec_power_pos x p `(Reduced x) : Reduced (power_pos x p). - Proof. - destruct x as [z | n d]; simpl; intros. - red; simpl; auto. - red; simpl; intros. - rewrite strong_spec_norm; simpl. - destr_eqb; nzsimpl; intros. - simpl; auto. - rewrite Qred_iff. - revert H. - unfold Reduced; rewrite strong_spec_red, Qred_iff; simpl. - destr_eqb; nzsimpl; simpl; intros. - exfalso. - rewrite NN.spec_pow_pos in *. nsubst. - rewrite Z.pow_0_l' in *; [romega|discriminate]. - rewrite Z2Pos.id in *; auto. - rewrite NN.spec_pow_pos, ZZ.spec_pow_pos; auto. - rewrite Zgcd_1_rel_prime in *. - apply rel_prime_Zpower; auto with zarith. - Qed. - - Definition power (x : t) (z : Z) : t := - match z with - | Z0 => one - | Zpos p => power_pos x p - | Zneg p => inv (power_pos x p) - end. - - Theorem spec_power : forall x z, [power x z] == [x]^z. - Proof. - destruct z. - simpl; nzsimpl; red; auto. - apply spec_power_pos. - simpl. - rewrite spec_inv, spec_power_pos; apply Qeq_refl. - Qed. - - Definition power_norm (x : t) (z : Z) : t := - match z with - | Z0 => one - | Zpos p => power_pos x p - | Zneg p => inv_norm (power_pos x p) - end. - - Theorem spec_power_norm : forall x z, [power_norm x z] == [x]^z. - Proof. - destruct z. - simpl; nzsimpl; red; auto. - apply spec_power_pos. - simpl. - rewrite spec_inv_norm, spec_power_pos; apply Qeq_refl. - Qed. - - Instance strong_spec_power_norm x z : - Reduced x -> Reduced (power_norm x z). - Proof. - destruct z; simpl. - intros _; unfold Reduced; rewrite strong_spec_red. - unfold one. - simpl to_Q; nzsimpl; auto. - intros; apply strong_spec_power_pos; auto. - intros; apply strong_spec_inv_norm; apply strong_spec_power_pos; auto. - Qed. - - - (** Interaction with [Qcanon.Qc] *) - - Open Scope Qc_scope. - - Definition of_Qc q := of_Q (this q). - - Definition to_Qc q := Q2Qc [q]. - - Notation "[[ x ]]" := (to_Qc x). - - Theorem strong_spec_of_Qc : forall q, [of_Qc q] = q. - Proof. - intros (q,Hq); intros. - unfold of_Qc; rewrite strong_spec_of_Q; auto. - Qed. - - Instance strong_spec_of_Qc_bis q : Reduced (of_Qc q). - Proof. - intros; red; rewrite strong_spec_red, strong_spec_of_Qc. - destruct q; simpl; auto. - Qed. - - Theorem spec_of_Qc: forall q, [[of_Qc q]] = q. - Proof. - intros; apply Qc_decomp; simpl; intros. - rewrite strong_spec_of_Qc. apply canon. - Qed. - - Theorem spec_oppc: forall q, [[opp q]] = -[[q]]. - Proof. - intros q; unfold Qcopp, to_Qc, Q2Qc. - apply Qc_decomp; unfold this. - apply Qred_complete. - rewrite spec_opp, <- Qred_opp, Qred_correct. - apply Qeq_refl. - Qed. - - Theorem spec_oppc_bis : forall q : Qc, [opp (of_Qc q)] = - q. - Proof. - intros. - rewrite <- strong_spec_opp_norm by apply strong_spec_of_Qc_bis. - rewrite strong_spec_red. - symmetry; apply (Qred_complete (-q)%Q). - rewrite spec_opp, strong_spec_of_Qc; auto with qarith. - Qed. - - Theorem spec_comparec: forall q1 q2, - compare q1 q2 = ([[q1]] ?= [[q2]]). - Proof. - unfold Qccompare, to_Qc. - intros q1 q2; rewrite spec_compare; simpl; auto. - apply Qcompare_comp; apply Qeq_sym; apply Qred_correct. - Qed. - - Theorem spec_addc x y: - [[add x y]] = [[x]] + [[y]]. - Proof. - unfold to_Qc. - transitivity (Q2Qc ([x] + [y])). - unfold Q2Qc. - apply Qc_decomp; unfold this. - apply Qred_complete; apply spec_add; auto. - unfold Qcplus, Q2Qc. - apply Qc_decomp; unfold this. - apply Qred_complete. - apply Qplus_comp; apply Qeq_sym; apply Qred_correct. - Qed. - - Theorem spec_add_normc x y: - [[add_norm x y]] = [[x]] + [[y]]. - Proof. - unfold to_Qc. - transitivity (Q2Qc ([x] + [y])). - unfold Q2Qc. - apply Qc_decomp; unfold this. - apply Qred_complete; apply spec_add_norm; auto. - unfold Qcplus, Q2Qc. - apply Qc_decomp; unfold this. - apply Qred_complete. - apply Qplus_comp; apply Qeq_sym; apply Qred_correct. - Qed. - - Theorem spec_add_normc_bis : forall x y : Qc, - [add_norm (of_Qc x) (of_Qc y)] = x+y. - Proof. - intros. - rewrite <- strong_spec_add_norm by apply strong_spec_of_Qc_bis. - rewrite strong_spec_red. - symmetry; apply (Qred_complete (x+y)%Q). - rewrite spec_add_norm, ! strong_spec_of_Qc; auto with qarith. - Qed. - - Theorem spec_subc x y: [[sub x y]] = [[x]] - [[y]]. - Proof. - unfold sub; rewrite spec_addc; auto. - rewrite spec_oppc; ring. - Qed. - - Theorem spec_sub_normc x y: - [[sub_norm x y]] = [[x]] - [[y]]. - Proof. - unfold sub_norm; rewrite spec_add_normc; auto. - rewrite spec_oppc; ring. - Qed. - - Theorem spec_sub_normc_bis : forall x y : Qc, - [sub_norm (of_Qc x) (of_Qc y)] = x-y. - Proof. - intros. - rewrite <- strong_spec_sub_norm by apply strong_spec_of_Qc_bis. - rewrite strong_spec_red. - symmetry; apply (Qred_complete (x+(-y)%Qc)%Q). - rewrite spec_sub_norm, ! strong_spec_of_Qc. - unfold Qcopp, Q2Qc, this. rewrite Qred_correct ; auto with qarith. - Qed. - - Theorem spec_mulc x y: - [[mul x y]] = [[x]] * [[y]]. - Proof. - unfold to_Qc. - transitivity (Q2Qc ([x] * [y])). - unfold Q2Qc. - apply Qc_decomp; unfold this. - apply Qred_complete; apply spec_mul; auto. - unfold Qcmult, Q2Qc. - apply Qc_decomp; unfold this. - apply Qred_complete. - apply Qmult_comp; apply Qeq_sym; apply Qred_correct. - Qed. - - Theorem spec_mul_normc x y: - [[mul_norm x y]] = [[x]] * [[y]]. - Proof. - unfold to_Qc. - transitivity (Q2Qc ([x] * [y])). - unfold Q2Qc. - apply Qc_decomp; unfold this. - apply Qred_complete; apply spec_mul_norm; auto. - unfold Qcmult, Q2Qc. - apply Qc_decomp; unfold this. - apply Qred_complete. - apply Qmult_comp; apply Qeq_sym; apply Qred_correct. - Qed. - - Theorem spec_mul_normc_bis : forall x y : Qc, - [mul_norm (of_Qc x) (of_Qc y)] = x*y. - Proof. - intros. - rewrite <- strong_spec_mul_norm by apply strong_spec_of_Qc_bis. - rewrite strong_spec_red. - symmetry; apply (Qred_complete (x*y)%Q). - rewrite spec_mul_norm, ! strong_spec_of_Qc; auto with qarith. - Qed. - - Theorem spec_invc x: - [[inv x]] = /[[x]]. - Proof. - unfold to_Qc. - transitivity (Q2Qc (/[x])). - unfold Q2Qc. - apply Qc_decomp; unfold this. - apply Qred_complete; apply spec_inv; auto. - unfold Qcinv, Q2Qc. - apply Qc_decomp; unfold this. - apply Qred_complete. - apply Qinv_comp; apply Qeq_sym; apply Qred_correct. - Qed. - - Theorem spec_inv_normc x: - [[inv_norm x]] = /[[x]]. - Proof. - unfold to_Qc. - transitivity (Q2Qc (/[x])). - unfold Q2Qc. - apply Qc_decomp; unfold this. - apply Qred_complete; apply spec_inv_norm; auto. - unfold Qcinv, Q2Qc. - apply Qc_decomp; unfold this. - apply Qred_complete. - apply Qinv_comp; apply Qeq_sym; apply Qred_correct. - Qed. - - Theorem spec_inv_normc_bis : forall x : Qc, - [inv_norm (of_Qc x)] = /x. - Proof. - intros. - rewrite <- strong_spec_inv_norm by apply strong_spec_of_Qc_bis. - rewrite strong_spec_red. - symmetry; apply (Qred_complete (/x)%Q). - rewrite spec_inv_norm, ! strong_spec_of_Qc; auto with qarith. - Qed. - - Theorem spec_divc x y: [[div x y]] = [[x]] / [[y]]. - Proof. - unfold div; rewrite spec_mulc; auto. - unfold Qcdiv; apply f_equal2 with (f := Qcmult); auto. - apply spec_invc; auto. - Qed. - - Theorem spec_div_normc x y: [[div_norm x y]] = [[x]] / [[y]]. - Proof. - unfold div_norm; rewrite spec_mul_normc; auto. - unfold Qcdiv; apply f_equal2 with (f := Qcmult); auto. - apply spec_inv_normc; auto. - Qed. - - Theorem spec_div_normc_bis : forall x y : Qc, - [div_norm (of_Qc x) (of_Qc y)] = x/y. - Proof. - intros. - rewrite <- strong_spec_div_norm by apply strong_spec_of_Qc_bis. - rewrite strong_spec_red. - symmetry; apply (Qred_complete (x*(/y)%Qc)%Q). - rewrite spec_div_norm, ! strong_spec_of_Qc. - unfold Qcinv, Q2Qc, this; rewrite Qred_correct; auto with qarith. - Qed. - - Theorem spec_squarec x: [[square x]] = [[x]]^2. - Proof. - unfold to_Qc. - transitivity (Q2Qc ([x]^2)). - unfold Q2Qc. - apply Qc_decomp; unfold this. - apply Qred_complete; apply spec_square; auto. - simpl Qcpower. - replace (Q2Qc [x] * 1) with (Q2Qc [x]); try ring. - simpl. - unfold Qcmult, Q2Qc. - apply Qc_decomp; unfold this. - apply Qred_complete. - apply Qmult_comp; apply Qeq_sym; apply Qred_correct. - Qed. - - Theorem spec_power_posc x p: - [[power_pos x p]] = [[x]] ^ Pos.to_nat p. - Proof. - unfold to_Qc. - transitivity (Q2Qc ([x]^Zpos p)). - unfold Q2Qc. - apply Qc_decomp; unfold this. - apply Qred_complete; apply spec_power_pos; auto. - induction p using Pos.peano_ind. - simpl; ring. - rewrite Pos2Nat.inj_succ; simpl Qcpower. - rewrite <- IHp; clear IHp. - unfold Qcmult, Q2Qc. - apply Qc_decomp; unfold this. - apply Qred_complete. - setoid_replace ([x] ^ ' Pos.succ p)%Q with ([x] * [x] ^ ' p)%Q. - apply Qmult_comp; apply Qeq_sym; apply Qred_correct. - simpl. - rewrite <- Pos.add_1_l. - rewrite Qpower_plus_positive; simpl; apply Qeq_refl. - Qed. - -End Make. diff --git a/theories/Numbers/Rational/SpecViaQ/QSig.v b/theories/Numbers/Rational/SpecViaQ/QSig.v deleted file mode 100644 index 8e20fd0608..0000000000 --- a/theories/Numbers/Rational/SpecViaQ/QSig.v +++ /dev/null @@ -1,229 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -Require Import QArith Qpower Qminmax Orders RelationPairs GenericMinMax. - -Open Scope Q_scope. - -(** * QSig *) - -(** Interface of a rich structure about rational numbers. - Specifications are written via translation to Q. -*) - -Module Type QType. - - Parameter t : Type. - - Parameter to_Q : t -> Q. - Local Notation "[ x ]" := (to_Q x). - - Definition eq x y := [x] == [y]. - Definition lt x y := [x] < [y]. - Definition le x y := [x] <= [y]. - - Parameter of_Q : Q -> t. - Parameter spec_of_Q: forall x, to_Q (of_Q x) == x. - - Parameter red : t -> t. - Parameter compare : t -> t -> comparison. - Parameter eq_bool : t -> t -> bool. - Parameter max : t -> t -> t. - Parameter min : t -> t -> t. - Parameter zero : t. - Parameter one : t. - Parameter minus_one : t. - Parameter add : t -> t -> t. - Parameter sub : t -> t -> t. - Parameter opp : t -> t. - Parameter mul : t -> t -> t. - Parameter square : t -> t. - Parameter inv : t -> t. - Parameter div : t -> t -> t. - Parameter power : t -> Z -> t. - - Parameter spec_red : forall x, [red x] == [x]. - Parameter strong_spec_red : forall x, [red x] = Qred [x]. - Parameter spec_compare : forall x y, compare x y = ([x] ?= [y]). - Parameter spec_eq_bool : forall x y, eq_bool x y = Qeq_bool [x] [y]. - Parameter spec_max : forall x y, [max x y] == Qmax [x] [y]. - Parameter spec_min : forall x y, [min x y] == Qmin [x] [y]. - Parameter spec_0: [zero] == 0. - Parameter spec_1: [one] == 1. - Parameter spec_m1: [minus_one] == -(1). - Parameter spec_add: forall x y, [add x y] == [x] + [y]. - Parameter spec_sub: forall x y, [sub x y] == [x] - [y]. - Parameter spec_opp: forall x, [opp x] == - [x]. - Parameter spec_mul: forall x y, [mul x y] == [x] * [y]. - Parameter spec_square: forall x, [square x] == [x] ^ 2. - Parameter spec_inv : forall x, [inv x] == / [x]. - Parameter spec_div: forall x y, [div x y] == [x] / [y]. - Parameter spec_power: forall x z, [power x z] == [x] ^ z. - -End QType. - -(** NB: several of the above functions come with [..._norm] variants - that expect reduced arguments and return reduced results. *) - -(** TODO : also speak of specifications via Qcanon ... *) - -Module Type QType_Notation (Import Q : QType). - Notation "[ x ]" := (to_Q x). - Infix "==" := eq (at level 70). - Notation "x != y" := (~x==y) (at level 70). - Infix "<=" := le. - Infix "<" := lt. - Notation "0" := zero. - Notation "1" := one. - Infix "+" := add. - Infix "-" := sub. - Infix "*" := mul. - Notation "- x" := (opp x). - Infix "/" := div. - Notation "/ x" := (inv x). - Infix "^" := power. -End QType_Notation. - -Module Type QType' := QType <+ QType_Notation. - - -Module QProperties (Import Q : QType'). - -(** Conversion to Q *) - -Hint Rewrite - spec_red spec_compare spec_eq_bool spec_min spec_max - spec_add spec_sub spec_opp spec_mul spec_square spec_inv spec_div - spec_power : qsimpl. -Ltac qify := unfold eq, lt, le in *; autorewrite with qsimpl; - try rewrite spec_0 in *; try rewrite spec_1 in *; try rewrite spec_m1 in *. - -(** NB: do not add [spec_0] in the autorewrite database. Otherwise, - after instantiation in BigQ, this lemma become convertible to 0=0, - and autorewrite loops. Idem for [spec_1] and [spec_m1] *) - -(** Morphisms *) - -Ltac solve_wd1 := intros x x' Hx; qify; now rewrite Hx. -Ltac solve_wd2 := intros x x' Hx y y' Hy; qify; now rewrite Hx, Hy. - -Local Obligation Tactic := solve_wd2 || solve_wd1. - -Instance : Measure to_Q. -Instance eq_equiv : Equivalence eq. -Proof. - change eq with (RelCompFun Qeq to_Q); apply _. -Defined. - -Program Instance lt_wd : Proper (eq==>eq==>iff) lt. -Program Instance le_wd : Proper (eq==>eq==>iff) le. -Program Instance red_wd : Proper (eq==>eq) red. -Program Instance compare_wd : Proper (eq==>eq==>Logic.eq) compare. -Program Instance eq_bool_wd : Proper (eq==>eq==>Logic.eq) eq_bool. -Program Instance min_wd : Proper (eq==>eq==>eq) min. -Program Instance max_wd : Proper (eq==>eq==>eq) max. -Program Instance add_wd : Proper (eq==>eq==>eq) add. -Program Instance sub_wd : Proper (eq==>eq==>eq) sub. -Program Instance opp_wd : Proper (eq==>eq) opp. -Program Instance mul_wd : Proper (eq==>eq==>eq) mul. -Program Instance square_wd : Proper (eq==>eq) square. -Program Instance inv_wd : Proper (eq==>eq) inv. -Program Instance div_wd : Proper (eq==>eq==>eq) div. -Program Instance power_wd : Proper (eq==>Logic.eq==>eq) power. - -(** Let's implement [HasCompare] *) - -Lemma compare_spec : forall x y, CompareSpec (x==y) (x<y) (y<x) (compare x y). -Proof. intros. qify. destruct (Qcompare_spec [x] [y]); auto. Qed. - -(** Let's implement [TotalOrder] *) - -Definition lt_compat := lt_wd. -Instance lt_strorder : StrictOrder lt. -Proof. - change lt with (RelCompFun Qlt to_Q); apply _. -Qed. - -Lemma le_lteq : forall x y, x<=y <-> x<y \/ x==y. -Proof. intros. qify. apply Qle_lteq. Qed. - -Lemma lt_total : forall x y, x<y \/ x==y \/ y<x. -Proof. intros. destruct (compare_spec x y); auto. Qed. - -(** Let's implement [HasEqBool] *) - -Definition eqb := eq_bool. - -Lemma eqb_eq : forall x y, eq_bool x y = true <-> x == y. -Proof. intros. qify. apply Qeq_bool_iff. Qed. - -Lemma eqb_correct : forall x y, eq_bool x y = true -> x == y. -Proof. now apply eqb_eq. Qed. - -Lemma eqb_complete : forall x y, x == y -> eq_bool x y = true. -Proof. now apply eqb_eq. Qed. - -(** Let's implement [HasMinMax] *) - -Lemma max_l : forall x y, y<=x -> max x y == x. -Proof. intros x y. qify. apply Qminmax.Q.max_l. Qed. - -Lemma max_r : forall x y, x<=y -> max x y == y. -Proof. intros x y. qify. apply Qminmax.Q.max_r. Qed. - -Lemma min_l : forall x y, x<=y -> min x y == x. -Proof. intros x y. qify. apply Qminmax.Q.min_l. Qed. - -Lemma min_r : forall x y, y<=x -> min x y == y. -Proof. intros x y. qify. apply Qminmax.Q.min_r. Qed. - -(** Q is a ring *) - -Lemma add_0_l : forall x, 0+x == x. -Proof. intros. qify. apply Qplus_0_l. Qed. - -Lemma add_comm : forall x y, x+y == y+x. -Proof. intros. qify. apply Qplus_comm. Qed. - -Lemma add_assoc : forall x y z, x+(y+z) == x+y+z. -Proof. intros. qify. apply Qplus_assoc. Qed. - -Lemma mul_1_l : forall x, 1*x == x. -Proof. intros. qify. apply Qmult_1_l. Qed. - -Lemma mul_comm : forall x y, x*y == y*x. -Proof. intros. qify. apply Qmult_comm. Qed. - -Lemma mul_assoc : forall x y z, x*(y*z) == x*y*z. -Proof. intros. qify. apply Qmult_assoc. Qed. - -Lemma mul_add_distr_r : forall x y z, (x+y)*z == x*z + y*z. -Proof. intros. qify. apply Qmult_plus_distr_l. Qed. - -Lemma sub_add_opp : forall x y, x-y == x+(-y). -Proof. intros. qify. now unfold Qminus. Qed. - -Lemma add_opp_diag_r : forall x, x+(-x) == 0. -Proof. intros. qify. apply Qplus_opp_r. Qed. - -(** Q is a field *) - -Lemma neq_1_0 : 1!=0. -Proof. intros. qify. apply Q_apart_0_1. Qed. - -Lemma div_mul_inv : forall x y, x/y == x*(/y). -Proof. intros. qify. now unfold Qdiv. Qed. - -Lemma mul_inv_diag_l : forall x, x!=0 -> /x * x == 1. -Proof. intros x. qify. rewrite Qmult_comm. apply Qmult_inv_r. Qed. - -End QProperties. - -Module QTypeExt (Q : QType) - <: QType <: TotalOrder <: HasCompare Q <: HasMinMax Q <: HasEqBool Q - := Q <+ QProperties. diff --git a/theories/Program/Wf.v b/theories/Program/Wf.v index c490ea5166..6e51f61873 100644 --- a/theories/Program/Wf.v +++ b/theories/Program/Wf.v @@ -69,6 +69,7 @@ Section Well_founded. End Well_founded. +Require Coq.extraction.Extraction. Extraction Inline Fix_F_sub Fix_sub. Set Implicit Arguments. diff --git a/theories/QArith/Qcabs.v b/theories/QArith/Qcabs.v index c0ababfff5..e433ecffa1 100644 --- a/theories/QArith/Qcabs.v +++ b/theories/QArith/Qcabs.v @@ -22,7 +22,7 @@ Lemma Qcabs_canon (x : Q) : Qred x = x -> Qred (Qabs x) = Qabs x. Proof. intros H; now rewrite (Qred_abs x), H. Qed. Definition Qcabs (x:Qc) : Qc := {| canon := Qcabs_canon x (canon x) |}. -Notation "[ q ]" := (Qcabs q) (q at next level, format "[ q ]") : Qc_scope. +Notation "[ q ]" := (Qcabs q) : Qc_scope. Ltac Qc_unfolds := unfold Qcabs, Qcminus, Qcopp, Qcplus, Qcmult, Qcle, Q2Qc, this. diff --git a/theories/Reals/SeqProp.v b/theories/Reals/SeqProp.v index 3697999f70..6a5233b643 100644 --- a/theories/Reals/SeqProp.v +++ b/theories/Reals/SeqProp.v @@ -150,7 +150,7 @@ Definition sequence_lb (Un:nat -> R) (pr:has_lb Un) (* Compatibility *) Notation sequence_majorant := sequence_ub (only parsing). Notation sequence_minorant := sequence_lb (only parsing). -Unset Standard Proposition Elimination Names. + Lemma Wn_decreasing : forall (Un:nat -> R) (pr:has_ub Un), Un_decreasing (sequence_ub Un pr). Proof. diff --git a/toplevel/coqinit.ml b/toplevel/coqinit.ml index 16fe405551..f36d0c348e 100644 --- a/toplevel/coqinit.ml +++ b/toplevel/coqinit.ml @@ -126,14 +126,12 @@ let init_ocaml_path () = Mltop.add_ml_dir (Envars.coqlib ()); List.iter add_subdir Coq_config.all_src_dirs -let get_compat_version = function +let get_compat_version ?(allow_old = true) = function | "8.7" -> Flags.Current | "8.6" -> Flags.V8_6 | "8.5" -> Flags.V8_5 - | "8.4" -> Flags.V8_4 - | "8.3" -> Flags.V8_3 - | "8.2" -> Flags.V8_2 - | ("8.1" | "8.0") as s -> + | ("8.4" | "8.3" | "8.2" | "8.1" | "8.0") as s -> + if allow_old then Flags.VOld else CErrors.user_err ~hdr:"get_compat_version" (str "Compatibility with version " ++ str s ++ str " not supported.") | s -> CErrors.user_err ~hdr:"get_compat_version" diff --git a/toplevel/coqinit.mli b/toplevel/coqinit.mli index 3b42289eec..787dfb61a9 100644 --- a/toplevel/coqinit.mli +++ b/toplevel/coqinit.mli @@ -25,4 +25,4 @@ val init_library_roots : unit -> unit val init_ocaml_path : unit -> unit -val get_compat_version : string -> Flags.compat_version +val get_compat_version : ?allow_old:bool -> string -> Flags.compat_version diff --git a/toplevel/coqloop.ml b/toplevel/coqloop.ml index 908786565e..0b0ef67176 100644 --- a/toplevel/coqloop.ml +++ b/toplevel/coqloop.ml @@ -187,7 +187,7 @@ end from cycling. *) let make_prompt () = try - (Names.Id.to_string (Pfedit.get_current_proof_name ())) ^ " < " + (Names.Id.to_string (Proof_global.get_current_proof_name ())) ^ " < " with Proof_global.NoCurrentProof -> "Coq < " diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml index 31450ebd51..5f0716fd9f 100644 --- a/toplevel/coqtop.ml +++ b/toplevel/coqtop.ml @@ -205,9 +205,9 @@ let require () = let add_compat_require v = match v with - | Flags.V8_4 -> add_require "Coq.Compat.Coq84" | Flags.V8_5 -> add_require "Coq.Compat.Coq85" - | _ -> () + | Flags.V8_6 -> add_require "Coq.Compat.Coq86" + | Flags.VOld | Flags.Current -> () let compile_list = ref ([] : (bool * string) list) @@ -514,7 +514,9 @@ let parse_args arglist = |"-async-proofs-delegation-threshold" -> Flags.async_proofs_delegation_threshold:= get_float opt (next ()) |"-worker-id" -> set_worker_id opt (next ()) - |"-compat" -> let v = get_compat_version (next ()) in Flags.compat_version := v; add_compat_require v + |"-compat" -> + let v = get_compat_version ~allow_old:false (next ()) in + Flags.compat_version := v; add_compat_require v |"-compile" -> add_compile false (next ()) |"-compile-verbose" -> add_compile true (next ()) |"-dump-glob" -> Dumpglob.dump_into_file (next ()); glob_opt := true diff --git a/toplevel/vernac.ml b/toplevel/vernac.ml index a61ade7849..74c7663ca5 100644 --- a/toplevel/vernac.ml +++ b/toplevel/vernac.ml @@ -111,7 +111,7 @@ let pr_open_cur_subgoals () = with Proof_global.NoCurrentProof -> Pp.str "" let vernac_error msg = - Format.fprintf !Topfmt.err_ft "@[%a@]%!" Pp.pp_with msg; + Topfmt.std_logger Feedback.Error msg; flush_all (); exit 1 @@ -285,8 +285,13 @@ let ensure_exists f = (* Compile a vernac file *) let compile verbosely f = let check_pending_proofs () = - let pfs = Pfedit.get_all_proof_names () in - if not (List.is_empty pfs) then vernac_error (str "There are pending proofs") + let pfs = Proof_global.get_all_proof_names () in + if not (List.is_empty pfs) then + vernac_error (str "There are pending proofs: " + ++ (pfs + |> List.rev + |> prlist_with_sep pr_comma Names.Id.print) + ++ str ".") in match !Flags.compilation_mode with | BuildVo -> diff --git a/vernac/classes.ml b/vernac/classes.ml index 8e6a0f6a72..007b70bc0f 100644 --- a/vernac/classes.ml +++ b/vernac/classes.ml @@ -114,8 +114,8 @@ let instance_hook k info global imps ?hook cst = let declare_instance_constant k info global imps ?hook id pl poly evm term termtype = let kind = IsDefinition Instance in let evm = - let levels = Univ.LSet.union (Universes.universes_of_constr termtype) - (Universes.universes_of_constr term) in + let levels = Univ.LSet.union (Univops.universes_of_constr termtype) + (Univops.universes_of_constr term) in Evd.restrict_universe_context evm levels in let pl, uctx = Evd.universe_context ?names:pl evm in @@ -341,7 +341,7 @@ let new_instance ?(abstract=false) ?(global=false) ?(refine= !refine_instance) p if not (Option.is_empty term) then let init_refine = Tacticals.New.tclTHENLIST [ - Refine.refine (fun evm -> (evm,EConstr.of_constr (Option.get term))); + Refine.refine ~typecheck:false (fun evm -> (evm,EConstr.of_constr (Option.get term))); Proofview.Unsafe.tclNEWGOALS gls; Tactics.New.reduce_after_refine; ] @@ -420,6 +420,8 @@ let context poly l = let _ = Command.declare_definition id decl entry [] [] hook in Lib.sections_are_opened () || Lib.is_modtype_strict () in - let () = uctx := Univ.ContextSet.empty in status && nstatus - in List.fold_left fn true (List.rev ctx) + in + if Lib.sections_are_opened () then + Declare.declare_universe_context poly !uctx; + List.fold_left fn true (List.rev ctx) diff --git a/vernac/command.ml b/vernac/command.ml index b1425d7034..4064773561 100644 --- a/vernac/command.ml +++ b/vernac/command.ml @@ -106,7 +106,7 @@ let interp_definition pl bl p red_option c ctypopt = let c = EConstr.Unsafe.to_constr c in let nf,subst = Evarutil.e_nf_evars_and_universes evdref in let body = nf (it_mkLambda_or_LetIn c ctx) in - let vars = Universes.universes_of_constr body in + let vars = Univops.universes_of_constr body in let evd = Evd.restrict_universe_context !evdref vars in let pl, uctx = Evd.universe_context ?names:pl evd in imps1@(Impargs.lift_implicits nb_args imps2), pl, @@ -131,8 +131,8 @@ let interp_definition pl bl p red_option c ctypopt = in if not (try List.for_all chk imps2 with Not_found -> false) then warn_implicits_in_term (); - let vars = Univ.LSet.union (Universes.universes_of_constr body) - (Universes.universes_of_constr typ) in + let vars = Univ.LSet.union (Univops.universes_of_constr body) + (Univops.universes_of_constr typ) in let ctx = Evd.restrict_universe_context !evdref vars in let pl, uctx = Evd.universe_context ?names:pl ctx in imps1@(Impargs.lift_implicits nb_args impsty), pl, @@ -187,7 +187,7 @@ let declare_definition ident (local, p, k) ce pl imps hook = let () = definition_message ident in let gr = VarRef ident in let () = maybe_declare_manual_implicits false gr imps in - let () = if Pfedit.refining () then + let () = if Proof_global.there_are_pending_proofs () then warn_definition_not_visible ident in gr @@ -233,7 +233,7 @@ match local with let _ = declare_variable ident decl in let () = assumption_message ident in let () = - if not !Flags.quiet && Pfedit.refining () then + if not !Flags.quiet && Proof_global.there_are_pending_proofs () then Feedback.msg_info (str"Variable" ++ spc () ++ pr_id ident ++ strbrk " is not visible from current goals") in @@ -329,7 +329,7 @@ let do_assumptions_bound_univs coe kind nl id pl c = let nf, subst = Evarutil.e_nf_evars_and_universes evdref in let ty = EConstr.Unsafe.to_constr ty in let ty = nf ty in - let vars = Universes.universes_of_constr ty in + let vars = Univops.universes_of_constr ty in let evd = Evd.restrict_universe_context !evdref vars in let pl, uctx = Evd.universe_context ?names:pl evd in let uctx = Univ.ContextSet.of_context uctx in @@ -573,7 +573,7 @@ let check_param = function | CLocalAssum (nas, Generalized _, _) -> () | CLocalPattern _ -> assert false -let interp_mutual_inductive (paramsl,indl) notations poly prv finite = +let interp_mutual_inductive (paramsl,indl) notations cum poly prv finite = check_all_names_different indl; List.iter check_param paramsl; let env0 = Global.env() in @@ -649,16 +649,27 @@ let interp_mutual_inductive (paramsl,indl) notations poly prv finite = indimpls, List.map (fun impls -> userimpls @ (lift_implicits len impls)) cimpls) indimpls constructors in + let univs = + if poly then + if cum then + Cumulative_ind_entry (Universes.univ_inf_ind_from_universe_context uctx) + else Polymorphic_ind_entry uctx + else + Monomorphic_ind_entry uctx + in (* Build the mutual inductive entry *) - { mind_entry_params = List.map prepare_param ctx_params; - mind_entry_record = None; - mind_entry_finite = finite; - mind_entry_inds = entries; - mind_entry_polymorphic = poly; - mind_entry_private = if prv then Some false else None; - mind_entry_universes = uctx; - }, - pl, impls + let mind_ent = + { mind_entry_params = List.map prepare_param ctx_params; + mind_entry_record = None; + mind_entry_finite = finite; + mind_entry_inds = entries; + mind_entry_private = if prv then Some false else None; + mind_entry_universes = univs; + } + in + (if poly && cum then + Inductiveops.infer_inductive_subtyping env_ar evd mind_ent + else mind_ent), pl, impls (* Very syntactical equality *) let eq_local_binders bl1 bl2 = @@ -742,10 +753,10 @@ type one_inductive_impls = Impargs.manual_explicitation list (* for inds *)* Impargs.manual_explicitation list list (* for constrs *) -let do_mutual_inductive indl poly prv finite = +let do_mutual_inductive indl cum poly prv finite = let indl,coes,ntns = extract_mutual_inductive_declaration_components indl in (* Interpret the types *) - let mie,pl,impls = interp_mutual_inductive indl ntns poly prv finite in + let mie,pl,impls = interp_mutual_inductive indl ntns cum poly prv finite in (* Declare the mutual inductive block with its associated schemes *) ignore (declare_mutual_inductive_with_eliminations mie pl impls); (* Declare the possible notations of inductive types *) @@ -1208,7 +1219,7 @@ let declare_fixpoint local poly ((fixnames,fixdefs,fixtypes),pl,ctx,fiximps) ind let env = Global.env() in let indexes = search_guard env indexes fixdecls in let fiximps = List.map (fun (n,r,p) -> r) fiximps in - let vars = Universes.universes_of_constr (mkFix ((indexes,0),fixdecls)) in + let vars = Univops.universes_of_constr (mkFix ((indexes,0),fixdecls)) in let fixdecls = List.map_i (fun i _ -> mkFix ((indexes,i),fixdecls)) 0 fixnames in let evd = Evd.from_ctx ctx in @@ -1240,7 +1251,7 @@ let declare_cofixpoint local poly ((fixnames,fixdefs,fixtypes),pl,ctx,fiximps) n let fixdefs = List.map Option.get fixdefs in let fixdecls = prepare_recursive_declaration fixnames fixtypes fixdefs in let fixdecls = List.map_i (fun i _ -> mkCoFix (i,fixdecls)) 0 fixnames in - let vars = Universes.universes_of_constr (List.hd fixdecls) in + let vars = Univops.universes_of_constr (List.hd fixdecls) in let fixdecls = List.map Safe_typing.mk_pure_proof fixdecls in let fiximps = List.map (fun (len,imps,idx) -> imps) fiximps in let evd = Evd.from_ctx ctx in diff --git a/vernac/command.mli b/vernac/command.mli index 9bbc2fdac1..a636bc03c5 100644 --- a/vernac/command.mli +++ b/vernac/command.mli @@ -15,7 +15,6 @@ open Vernacexpr open Constrexpr open Decl_kinds open Redexpr -open Pfedit (** This file is about the interpretation of raw commands into typed ones and top-level declaration of the main Gallina objects *) @@ -91,9 +90,9 @@ type one_inductive_impls = Impargs.manual_implicits list (** for constrs *) val interp_mutual_inductive : - structured_inductive_expr -> decl_notation list -> polymorphic -> - private_flag -> Decl_kinds.recursivity_kind -> - mutual_inductive_entry * Universes.universe_binders * one_inductive_impls list + structured_inductive_expr -> decl_notation list -> cumulative_inductive_flag -> + polymorphic -> private_flag -> Decl_kinds.recursivity_kind -> + mutual_inductive_entry * Universes.universe_binders * one_inductive_impls list (** Registering a mutual inductive definition together with its associated schemes *) @@ -105,8 +104,8 @@ val declare_mutual_inductive_with_eliminations : (** Entry points for the vernacular commands Inductive and CoInductive *) val do_mutual_inductive : - (one_inductive_expr * decl_notation list) list -> polymorphic -> - private_flag -> Decl_kinds.recursivity_kind -> unit + (one_inductive_expr * decl_notation list) list -> cumulative_inductive_flag -> + polymorphic -> private_flag -> Decl_kinds.recursivity_kind -> unit (** {6 Fixpoints and cofixpoints} *) @@ -151,7 +150,7 @@ val declare_fixpoint : locality -> polymorphic -> recursive_preentry * lident list option * Evd.evar_universe_context * (Context.Rel.t * Impargs.manual_implicits * int option) list -> - lemma_possible_guards -> decl_notation list -> unit + Proof_global.lemma_possible_guards -> decl_notation list -> unit val declare_cofixpoint : locality -> polymorphic -> recursive_preentry * lident list option * Evd.evar_universe_context * diff --git a/vernac/discharge.ml b/vernac/discharge.ml index 65ade78876..18f93334b1 100644 --- a/vernac/discharge.ml +++ b/vernac/discharge.ml @@ -79,12 +79,14 @@ let refresh_polymorphic_type_of_inductive (_,mip) = let process_inductive (sechyps,abs_ctx) modlist mib = let nparams = mib.mind_nparams in - let subst, univs = - if mib.mind_polymorphic then - let inst = Univ.UContext.instance mib.mind_universes in - let cstrs = Univ.UContext.constraints mib.mind_universes in - inst, Univ.UContext.make (inst, Univ.subst_instance_constraints inst cstrs) - else Univ.Instance.empty, mib.mind_universes + let subst, univs = + match mib.mind_universes with + | Monomorphic_ind ctx -> Univ.Instance.empty, ctx + | Polymorphic_ind auctx -> + Univ.AUContext.instance auctx, Univ.instantiate_univ_context auctx + | Cumulative_ind cumi -> + let auctx = Univ.ACumulativityInfo.univ_context cumi in + Univ.AUContext.instance auctx, Univ.instantiate_univ_context auctx in let inds = Array.map_to_list @@ -105,6 +107,12 @@ let process_inductive (sechyps,abs_ctx) modlist mib = let (params',inds') = abstract_inductive sechyps' nparams inds in let abs_ctx = Univ.instantiate_univ_context abs_ctx in let univs = Univ.UContext.union abs_ctx univs in + let ind_univs = + match mib.mind_universes with + | Monomorphic_ind _ -> Monomorphic_ind_entry univs + | Polymorphic_ind _ -> Polymorphic_ind_entry univs + | Cumulative_ind _ -> + Cumulative_ind_entry (Universes.univ_inf_ind_from_universe_context univs) in let record = match mib.mind_record with | Some (Some (id, _, _)) -> Some (Some id) | Some None -> Some None @@ -114,7 +122,7 @@ let process_inductive (sechyps,abs_ctx) modlist mib = mind_entry_finite = mib.mind_finite; mind_entry_params = params'; mind_entry_inds = inds'; - mind_entry_polymorphic = mib.mind_polymorphic; mind_entry_private = mib.mind_private; - mind_entry_universes = univs; + mind_entry_universes = ind_univs } + diff --git a/vernac/discharge.mli b/vernac/discharge.mli index 18d1b67766..3845c04a11 100644 --- a/vernac/discharge.mli +++ b/vernac/discharge.mli @@ -11,4 +11,5 @@ open Entries open Opaqueproof val process_inductive : - Context.Named.t Univ.in_universe_context -> work_list -> mutual_inductive_body -> mutual_inductive_entry + ((Term.constr, Term.constr) Context.Named.pt * Univ.abstract_universe_context) + -> work_list -> mutual_inductive_body -> mutual_inductive_entry diff --git a/vernac/himsg.ml b/vernac/himsg.ml index 6d8dd82ac6..ce91e1a09f 100644 --- a/vernac/himsg.ml +++ b/vernac/himsg.ml @@ -889,6 +889,10 @@ let explain_not_match_error = function | NoTypeConstraintExpected -> strbrk "a definition whose type is constrained can only be subtype " ++ strbrk "of a definition whose type is itself constrained" + | CumulativeStatusExpected b -> + let status b = if b then str"cumulative" else str"non-cumulative" in + str "a " ++ status b ++ str" declaration was expected, but a " ++ + status (not b) ++ str" declaration was found" | PolymorphicStatusExpected b -> let status b = if b then str"polymorphic" else str"monomorphic" in str "a " ++ status b ++ str" declaration was expected, but a " ++ diff --git a/vernac/ind_tables.ml b/vernac/ind_tables.ml index f3259f1f3b..65d42b6267 100644 --- a/vernac/ind_tables.ml +++ b/vernac/ind_tables.ml @@ -148,7 +148,7 @@ let define_individual_scheme_base kind suff f mode idopt (mind,i as ind) = let id = match idopt with | Some id -> id | None -> add_suffix mib.mind_packets.(i).mind_typename suff in - let const = define mode id c mib.mind_polymorphic ctx in + let const = define mode id c (Declareops.inductive_is_polymorphic mib) ctx in declare_scheme kind [|ind,const|]; const, Safe_typing.add_private (Safe_typing.private_con_of_scheme ~kind (Global.safe_env()) [ind,const]) eff @@ -166,7 +166,7 @@ let define_mutual_scheme_base kind suff f mode names mind = try Int.List.assoc i names with Not_found -> add_suffix mib.mind_packets.(i).mind_typename suff) in let consts = Array.map2 (fun id cl -> - define mode id cl mib.mind_polymorphic ctx) ids cl in + define mode id cl (Declareops.inductive_is_polymorphic mib) ctx) ids cl in let schemes = Array.mapi (fun i cst -> ((mind,i),cst)) consts in declare_scheme kind schemes; consts, diff --git a/vernac/indschemes.ml b/vernac/indschemes.ml index c2c27eb78e..44d6f37cc6 100644 --- a/vernac/indschemes.ml +++ b/vernac/indschemes.ml @@ -84,15 +84,8 @@ let _ = optkey = ["Boolean";"Equality";"Schemes"]; optread = (fun () -> !eq_flag) ; optwrite = (fun b -> eq_flag := b) } -let _ = (* compatibility *) - declare_bool_option - { optdepr = true; - optname = "automatic declaration of boolean equality"; - optkey = ["Equality";"Scheme"]; - optread = (fun () -> !eq_flag) ; - optwrite = (fun b -> eq_flag := b) } -let is_eq_flag () = !eq_flag && Flags.version_strictly_greater Flags.V8_2 +let is_eq_flag () = !eq_flag let eq_dec_flag = ref false let _ = diff --git a/vernac/lemmas.ml b/vernac/lemmas.ml index 77e356eb2c..5bf419caf5 100644 --- a/vernac/lemmas.ml +++ b/vernac/lemmas.ml @@ -209,7 +209,7 @@ let compute_proof_name locality = function user_err ?loc (pr_id id ++ str " already exists."); id, pl | None -> - next_global_ident_away default_thm_id (Pfedit.get_all_proof_names ()), None + next_global_ident_away default_thm_id (Proof_global.get_all_proof_names ()), None let save_remaining_recthms (locality,p,kind) norm ctx body opaq i ((id,pl),(t_i,(_,imps))) = let t_i = norm t_i in @@ -487,7 +487,7 @@ let save_proof ?proof = function let sec_vars = if !keep_admitted_vars then const_entry_secctx else None in Admitted(id, k, (sec_vars, pi2 k, (typ, ctx), None), universes) | None -> - let pftree = Pfedit.get_pftreestate () in + let pftree = Proof_global.give_me_the_proof () in let id, k, typ = Pfedit.current_proof_statement () in let typ = EConstr.Unsafe.to_constr typ in let universes = Proof.initial_euctx pftree in @@ -496,7 +496,7 @@ let save_proof ?proof = function Proof_global.return_proof ~allow_partial:true () in let sec_vars = if not !keep_admitted_vars then None - else match Pfedit.get_used_variables(), pproofs with + else match Proof_global.get_used_variables(), pproofs with | Some _ as x, _ -> x | None, (pproof, _) :: _ -> let env = Global.env () in @@ -504,7 +504,7 @@ let save_proof ?proof = function let ids_def = Environ.global_vars_set env pproof in Some (Environ.keep_hyps env (Idset.union ids_typ ids_def)) | _ -> None in - let names = Pfedit.get_universe_binders () in + let names = Proof_global.get_universe_binders () in let evd = Evd.from_ctx universes in let binders, ctx = Evd.universe_context ?names evd in Admitted(id,k,(sec_vars, pi2 k, (typ, ctx), None), @@ -519,7 +519,7 @@ let save_proof ?proof = function | Some proof -> proof in (* if the proof is given explicitly, nothing has to be deleted *) - if Option.is_empty proof then Pfedit.delete_current_proof (); + if Option.is_empty proof then Proof_global.discard_current (); Proof_global.(apply_terminator terminator (Proved (is_opaque,idopt,proof_obj))) (* Miscellaneous *) diff --git a/vernac/lemmas.mli b/vernac/lemmas.mli index d06b8fd14b..a9c0d99f30 100644 --- a/vernac/lemmas.mli +++ b/vernac/lemmas.mli @@ -9,7 +9,6 @@ open Names open Term open Decl_kinds -open Pfedit type 'a declaration_hook val mk_hook : @@ -21,16 +20,16 @@ val call_hook : (** A hook start_proof calls on the type of the definition being started *) val set_start_hook : (EConstr.types -> unit) -> unit -val start_proof : Id.t -> ?pl:universe_binders -> goal_kind -> Evd.evar_map -> - ?terminator:(lemma_possible_guards -> unit declaration_hook -> Proof_global.proof_terminator) -> +val start_proof : Id.t -> ?pl:Proof_global.universe_binders -> goal_kind -> Evd.evar_map -> + ?terminator:(Proof_global.lemma_possible_guards -> unit declaration_hook -> Proof_global.proof_terminator) -> ?sign:Environ.named_context_val -> EConstr.types -> - ?init_tac:unit Proofview.tactic -> ?compute_guard:lemma_possible_guards -> + ?init_tac:unit Proofview.tactic -> ?compute_guard:Proof_global.lemma_possible_guards -> unit declaration_hook -> unit -val start_proof_univs : Id.t -> ?pl:universe_binders -> goal_kind -> Evd.evar_map -> - ?terminator:(lemma_possible_guards -> (Evd.evar_universe_context option -> unit declaration_hook) -> Proof_global.proof_terminator) -> +val start_proof_univs : Id.t -> ?pl:Proof_global.universe_binders -> goal_kind -> Evd.evar_map -> + ?terminator:(Proof_global.lemma_possible_guards -> (Evd.evar_universe_context option -> unit declaration_hook) -> Proof_global.proof_terminator) -> ?sign:Environ.named_context_val -> EConstr.types -> - ?init_tac:unit Proofview.tactic -> ?compute_guard:lemma_possible_guards -> + ?init_tac:unit Proofview.tactic -> ?compute_guard:Proof_global.lemma_possible_guards -> (Evd.evar_universe_context option -> unit declaration_hook) -> unit val start_proof_com : @@ -40,8 +39,8 @@ val start_proof_com : val start_proof_with_initialization : goal_kind -> Evd.evar_map -> - (bool * lemma_possible_guards * unit Proofview.tactic list option) option -> - ((Id.t (* name of thm *) * universe_binders option) * + (bool * Proof_global.lemma_possible_guards * unit Proofview.tactic list option) option -> + ((Id.t (* name of thm *) * Proof_global.universe_binders option) * (types (* type of thm *) * (Name.t list (* names to pre-introduce *) * Impargs.manual_explicitation list))) list -> int list option -> unit declaration_hook -> unit diff --git a/vernac/obligations.ml b/vernac/obligations.ml index 6dee95bc54..135e4c63ab 100644 --- a/vernac/obligations.ml +++ b/vernac/obligations.ml @@ -365,8 +365,8 @@ let get_body obl = match obl.obl_body with | None -> None | Some (DefinedObl c) -> - let ctx = Environ.constant_context (Global.env ()) c in - let pc = (c, Univ.UContext.instance ctx) in + let u = Environ.constant_instance (Global.env ()) c in + let pc = (c, u) in Some (DefinedObl pc) | Some (TermObl c) -> Some (TermObl c) @@ -947,7 +947,7 @@ let rec solve_obligation prg num tac = let hook ctx = Lemmas.mk_hook (obligation_hook prg obl num auto ctx) in let () = Lemmas.start_proof_univs ~sign:prg.prg_sign obl.obl_name kind evd (EConstr.of_constr obl.obl_type) ~terminator hook in let _ = Pfedit.by !default_tactic in - Option.iter (fun tac -> Pfedit.set_end_tac tac) tac + Option.iter (fun tac -> Proof_global.set_endline_tactic tac) tac and obligation (user_num, name, typ) tac = let num = pred user_num in diff --git a/vernac/record.ml b/vernac/record.ml index 2400fa6814..7dd70d0133 100644 --- a/vernac/record.ml +++ b/vernac/record.ml @@ -265,10 +265,16 @@ let warn_non_primitive_record = let declare_projections indsp ?(kind=StructureComponent) binder_name coers fieldimpls fields = let env = Global.env() in let (mib,mip) = Global.lookup_inductive indsp in - let u = Declareops.inductive_instance mib in + let u = Declareops.inductive_polymorphic_instance mib in let paramdecls = Inductive.inductive_paramdecls (mib, u) in - let poly = mib.mind_polymorphic in - let ctx = Univ.instantiate_univ_context mib.mind_universes in + let poly = Declareops.inductive_is_polymorphic mib in + let ctx = + match mib.mind_universes with + | Monomorphic_ind ctx -> ctx + | Polymorphic_ind auctx -> Univ.instantiate_univ_context auctx + | Cumulative_ind cumi -> + Univ.instantiate_univ_context (Univ.ACumulativityInfo.univ_context cumi) + in let indu = indsp, u in let r = mkIndU (indsp,u) in let rp = applist (r, Context.Rel.to_extended_list mkRel 0 paramdecls) in @@ -377,12 +383,18 @@ let structure_signature ctx = open Typeclasses -let declare_structure finite poly ctx id idbuild paramimpls params arity template +let declare_structure finite univs id idbuild paramimpls params arity template fieldimpls fields ?(kind=StructureComponent) ?name is_coe coers sign = let nparams = List.length params and nfields = List.length fields in let args = Context.Rel.to_extended_list mkRel nfields params in let ind = applist (mkRel (1+nparams+nfields), args) in let type_constructor = it_mkProd_or_LetIn ind fields in + let poly, ctx = + match univs with + | Monomorphic_ind_entry ctx -> false, ctx + | Polymorphic_ind_entry ctx -> true, ctx + | Cumulative_ind_entry cumi -> true, (Univ.CumulativityInfo.univ_context cumi) + in let binder_name = match name with | None -> Id.of_string (Unicode.lowercase_first_char (Id.to_string id)) @@ -400,11 +412,22 @@ let declare_structure finite poly ctx id idbuild paramimpls params arity templat mind_entry_record = Some (if !primitive_flag then Some binder_name else None); mind_entry_finite = finite; mind_entry_inds = [mie_ind]; - mind_entry_polymorphic = poly; mind_entry_private = None; - mind_entry_universes = ctx; + mind_entry_universes = univs; } in + let mie = + if poly then + begin + let env = Global.env () in + let env' = Environ.push_context ctx env in + (* let env'' = Environ.push_rel_context params env' in *) + let evd = Evd.from_env env' in + Inductiveops.infer_inductive_subtyping env' evd mie + end + else + mie + in let kn = Command.declare_mutual_inductive_with_eliminations mie [] [(paramimpls,[])] in let rsp = (kn,0) in (* This is ind path of idstruc *) let cstr = (rsp,1) in @@ -423,7 +446,7 @@ let implicits_of_context ctx = in ExplByPos (i, explname), (true, true, true)) 1 (List.rev (Anonymous :: (List.map RelDecl.get_name ctx))) -let declare_class finite def poly ctx id idbuild paramimpls params arity +let declare_class finite def cum poly ctx id idbuild paramimpls params arity template fieldimpls fields ?(kind=StructureComponent) is_coe coers priorities sign = let fieldimpls = (* Make the class implicit in the projections, and the params if applicable. *) @@ -466,7 +489,16 @@ let declare_class finite def poly ctx id idbuild paramimpls params arity in cref, [Name proj_name, sub, Some proj_cst] | _ -> - let ind = declare_structure BiFinite poly ctx (snd id) idbuild paramimpls + let univs = + if poly then + if cum then + Cumulative_ind_entry (Universes.univ_inf_ind_from_universe_context ctx) + else + Polymorphic_ind_entry ctx + else + Monomorphic_ind_entry ctx + in + let ind = declare_structure BiFinite univs (snd id) idbuild paramimpls params arity template fieldimpls fields ~kind:Method ~name:binder_name false (List.map (fun _ -> false) fields) sign in @@ -515,7 +547,7 @@ let add_inductive_class ind = let mind, oneind = Global.lookup_inductive ind in let k = let ctx = oneind.mind_arity_ctxt in - let inst = Univ.UContext.instance mind.mind_universes in + let inst = Declareops.inductive_polymorphic_instance mind in let ty = Inductive.type_of_inductive (push_rel_context ctx (Global.env ())) ((mind,oneind),inst) @@ -540,7 +572,7 @@ open Vernacexpr (* [fs] corresponds to fields and [ps] to parameters; [coers] is a list telling if the corresponding fields must me declared as coercions or subinstances. *) -let definition_structure (kind,poly,finite,(is_coe,((loc,idstruc),pl)),ps,cfs,idbuild,s) = +let definition_structure (kind,cum,poly,finite,(is_coe,((loc,idstruc),pl)),ps,cfs,idbuild,s) = let cfs,notations = List.split cfs in let cfs,priorities = List.split cfs in let coers,fs = List.split cfs in @@ -564,14 +596,24 @@ let definition_structure (kind,poly,finite,(is_coe,((loc,idstruc),pl)),ps,cfs,id let gr = match kind with | Class def -> let priorities = List.map (fun id -> {hint_priority = id; hint_pattern = None}) priorities in - let gr = declare_class finite def poly ctx (loc,idstruc) idbuild + let gr = declare_class finite def cum poly ctx (loc,idstruc) idbuild implpars params arity template implfs fields is_coe coers priorities sign in gr | _ -> - let implfs = List.map + let implfs = List.map (fun impls -> implpars @ Impargs.lift_implicits - (succ (List.length params)) impls) implfs in - let ind = declare_structure finite poly ctx idstruc + (succ (List.length params)) impls) implfs + in + let univs = + if poly then + if cum then + Cumulative_ind_entry (Universes.univ_inf_ind_from_universe_context ctx) + else + Polymorphic_ind_entry ctx + else + Monomorphic_ind_entry ctx + in + let ind = declare_structure finite univs idstruc idbuild implpars params arity template implfs fields is_coe (List.map (fun coe -> not (Option.is_empty coe)) coers) sign in IndRef ind diff --git a/vernac/record.mli b/vernac/record.mli index 3fd651db90..aa530fd61a 100644 --- a/vernac/record.mli +++ b/vernac/record.mli @@ -26,7 +26,7 @@ val declare_projections : val declare_structure : Decl_kinds.recursivity_kind -> - bool (** polymorphic?*) -> Univ.universe_context -> + Entries.inductive_universes -> Id.t -> Id.t -> manual_explicitation list -> Context.Rel.t -> (** params *) constr -> (** arity *) bool (** template arity ? *) -> @@ -38,8 +38,8 @@ val declare_structure : inductive val definition_structure : - inductive_kind * Decl_kinds.polymorphic * Decl_kinds.recursivity_kind * - plident with_coercion * local_binder_expr list * + inductive_kind * Decl_kinds.cumulative_inductive_flag * Decl_kinds.polymorphic * + Decl_kinds.recursivity_kind * plident with_coercion * local_binder_expr list * (local_decl_expr with_instance with_priority with_notation) list * Id.t * constr_expr option -> global_reference diff --git a/vernac/search.ml b/vernac/search.ml index 0ff78f439d..5e56ada8ad 100644 --- a/vernac/search.ml +++ b/vernac/search.ml @@ -85,7 +85,7 @@ let iter_declarations (fn : global_reference -> env -> constr -> unit) = let mib = Global.lookup_mind mind in let iter_packet i mip = let ind = (mind, i) in - let u = Declareops.inductive_instance mib in + let u = Declareops.inductive_polymorphic_instance mib in let i = (ind, u) in let typ = Inductiveops.type_of_inductive env i in let () = fn (IndRef ind) env typ in diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index ef16df5b75..21f053fb9b 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -15,7 +15,6 @@ open Flags open Names open Nameops open Term -open Pfedit open Tacmach open Constrintern open Prettyp @@ -61,35 +60,25 @@ let show_proof () = let pprf = Proof.partial_proof p in Feedback.msg_notice (Pp.prlist_with_sep Pp.fnl Printer.pr_econstr pprf) -let show_node () = - (* spiwack: I'm have little clue what this function used to do. I deactivated it, - could, possibly, be cleaned away. (Feb. 2010) *) - () - -let show_thesis () = CErrors.anomaly (Pp.str "Show Thesis: TODO.") - let show_top_evars () = (* spiwack: new as of Feb. 2010: shows goal evars in addition to non-goal evars. *) - let pfts = get_pftreestate () in + let pfts = Proof_global.give_me_the_proof () in let gls = Proof.V82.subgoals pfts in let sigma = gls.Evd.sigma in Feedback.msg_notice (pr_evars_int sigma 1 (Evarutil.non_instantiated sigma)) let show_universes () = - let pfts = get_pftreestate () in + let pfts = Proof_global.give_me_the_proof () in let gls = Proof.V82.subgoals pfts in let sigma = gls.Evd.sigma in let ctx = Evd.universe_context_set (Evd.nf_constraints sigma) in Feedback.msg_notice (Termops.pr_evar_universe_context (Evd.evar_universe_context sigma)); Feedback.msg_notice (str"Normalized constraints: " ++ Univ.pr_universe_context_set (Termops.pr_evd_level sigma) ctx) -(* Spiwack: proof tree is currently not working *) -let show_prooftree () = () - (* Simulate the Intro(s) tactic *) let show_intro all = let open EConstr in - let pf = get_pftreestate() in + let pf = Proof_global.give_me_the_proof() in let {Evd.it=gls ; sigma=sigma; } = Proof.V82.subgoals pf in if not (List.is_empty gls) then begin let gl = {Evd.it=List.hd gls ; sigma = sigma; } in @@ -508,7 +497,7 @@ let vernac_start_proof locality p kind l lettop = match id with | Some (lid,_) -> Dumpglob.dump_definition lid false "prf" | None -> ()) l; - if not(refining ()) then + if not(Proof_global.there_are_pending_proofs ()) then if lettop then user_err ~hdr:"Vernacentries.StartProof" (str "Let declarations can only be used in proof editing mode."); @@ -521,7 +510,7 @@ let vernac_end_proof ?proof = function let vernac_exact_proof c = (* spiwack: for simplicity I do not enforce that "Proof proof_term" is called only at the begining of a proof. *) - let status = by (Tactics.exact_proof c) in + let status = Pfedit.by (Tactics.exact_proof c) in save_proof (Vernacexpr.(Proved(Opaque None,None))); if not status then Feedback.feedback Feedback.AddedAxiom @@ -537,7 +526,7 @@ let vernac_assumption locality poly (local, kind) l nl = let status = do_assumptions kind nl l in if not status then Feedback.feedback Feedback.AddedAxiom -let vernac_record k poly finite struc binders sort nameopt cfs = +let vernac_record cum k poly finite struc binders sort nameopt cfs = let const = match nameopt with | None -> add_prefix "Build_" (snd (fst (snd struc))) | Some (_,id as lid) -> @@ -548,13 +537,13 @@ let vernac_record k poly finite struc binders sort nameopt cfs = match x with | Vernacexpr.AssumExpr ((loc, Name id), _) -> Dumpglob.dump_definition (loc,id) false "proj" | _ -> ()) cfs); - ignore(Record.definition_structure (k,poly,finite,struc,binders,cfs,const,sort)) + ignore(Record.definition_structure (k,cum,poly,finite,struc,binders,cfs,const,sort)) (** When [poly] is true the type is declared polymorphic. When [lo] is true, then the type is declared private (as per the [Private] keyword). [finite] indicates whether the type is inductive, co-inductive or neither. *) -let vernac_inductive poly lo finite indl = +let vernac_inductive cum poly lo finite indl = if Dumpglob.dump () then List.iter (fun (((coe,(lid,_)), _, _, _, cstrs), _) -> match cstrs with @@ -570,14 +559,14 @@ let vernac_inductive poly lo finite indl = | [ (_ , _ , _ ,Variant, RecordDecl _),_ ] -> user_err Pp.(str "The Variant keyword does not support syntax { ... }.") | [ ( id , bl , c , b, RecordDecl (oc,fs) ), [] ] -> - vernac_record (match b with Class _ -> Class false | _ -> b) + vernac_record cum (match b with Class _ -> Class false | _ -> b) poly finite id bl c oc fs | [ ( id , bl , c , Class _, Constructors [l]), [] ] -> let f = let (coe, ((loc, id), ce)) = l in let coe' = if coe then Some true else None in (((coe', AssumExpr ((loc, Name id), ce)), None), []) - in vernac_record (Class true) poly finite id bl c None [f] + in vernac_record cum (Class true) poly finite id bl c None [f] | [ ( _ , _, _, Class _, Constructors _), [] ] -> user_err Pp.(str "Inductive classes not supported") | [ ( id , bl , c , Class _, _), _ :: _ ] -> @@ -591,7 +580,7 @@ let vernac_inductive poly lo finite indl = | _ -> user_err Pp.(str "Cannot handle mutually (co)inductive records.") in let indl = List.map unpack indl in - do_mutual_inductive indl poly lo finite + do_mutual_inductive indl cum poly lo finite let vernac_fixpoint locality poly local l = let local = enforce_locality_exp locality local in @@ -639,8 +628,7 @@ let vernac_constraint loc poly l = (* Modules *) let vernac_import export refl = - Library.import_module export (List.map qualid_of_reference refl); - Lib.add_frozen_state () + Library.import_module export (List.map qualid_of_reference refl) let vernac_declare_module export (loc, id) binders_ast mty_ast = (* We check the state of the system (in section, in module type) @@ -667,7 +655,7 @@ let vernac_define_module export (loc, id) binders_ast mty_ast_o mexpr_ast_l = user_err Pp.(str "Modules and Module Types are not allowed inside sections."); match mexpr_ast_l with | [] -> - check_no_pending_proofs (); + Proof_global.check_no_pending_proof (); let binders_ast,argsexport = List.fold_right (fun (export,idl,ty) (args,argsexport) -> @@ -713,7 +701,7 @@ let vernac_declare_module_type (loc,id) binders_ast mty_sign mty_ast_l = match mty_ast_l with | [] -> - check_no_pending_proofs (); + Proof_global.check_no_pending_proof (); let binders_ast,argsexport = List.fold_right (fun (export,idl,ty) (args,argsexport) -> @@ -761,7 +749,7 @@ let vernac_include l = (* Sections *) let vernac_begin_section (_, id as lid) = - check_no_pending_proofs (); + Proof_global.check_no_pending_proof (); Dumpglob.dump_definition lid true "sec"; Lib.open_section id @@ -775,7 +763,7 @@ let vernac_name_sec_hyp (_,id) set = Proof_using.name_set id set (* Dispatcher of the "End" command *) let vernac_end_segment (_,id as lid) = - check_no_pending_proofs (); + Proof_global.check_no_pending_proof (); match Lib.find_opening_node id with | Lib.OpenedModule (false,export,_,_) -> vernac_end_module export lid | Lib.OpenedModule (true,_,_,_) -> vernac_end_modtype lid @@ -855,14 +843,14 @@ let focus_command_cond = Proof.no_cond command_focus there are no more goals to solve. It cannot be a tactic since all tactics fail if there are no further goals to prove. *) -let vernac_solve_existential = instantiate_nth_evar_com +let vernac_solve_existential = Pfedit.instantiate_nth_evar_com let vernac_set_end_tac tac = let env = Genintern.empty_glob_sign (Global.env ()) in let _, tac = Genintern.generic_intern env tac in - if not (refining ()) then + if not (Proof_global.there_are_pending_proofs ()) then user_err Pp.(str "Unknown command of the non proof-editing mode."); - set_end_tac tac + Proof_global.set_endline_tactic tac (* TO DO verifier s'il faut pas mettre exist s | TacId s ici*) let vernac_set_used_variables e = @@ -877,13 +865,13 @@ let vernac_set_used_variables e = user_err ~hdr:"vernac_set_used_variables" (str "Unknown variable: " ++ pr_id id)) l; - let _, to_clear = set_used_variables l in + let _, to_clear = Proof_global.set_used_variables l in let to_clear = List.map snd to_clear in Proof_global.with_current_proof begin fun _ p -> if List.is_empty to_clear then (p, ()) else let tac = Tactics.clear to_clear in - fst (solve SelectAll None tac p), () + fst (Pfedit.solve SelectAll None tac p), () end (*****************************) @@ -927,12 +915,12 @@ let vernac_chdir = function (* State management *) let vernac_write_state file = - Pfedit.delete_all_proofs (); + Proof_global.discard_all (); let file = CUnix.make_suffix file ".coq" in States.extern_state file let vernac_restore_state file = - Pfedit.delete_all_proofs (); + Proof_global.discard_all (); let file = Loadpath.locate_file (CUnix.make_suffix file ".coq") in States.intern_state file @@ -1298,7 +1286,7 @@ let _ = let _ = declare_bool_option - { optdepr = false; + { optdepr = true; (* remove in 8.8 *) optname = "automatic introduction of variables"; optkey = ["Automatic";"Introduction"]; optread = Flags.is_auto_intros; @@ -1377,6 +1365,14 @@ let _ = optwrite = Flags.make_universe_polymorphism } let _ = + declare_bool_option + { optdepr = false; + optname = "inductive cumulativity"; + optkey = ["Inductive"; "Cumulativity"]; + optread = Flags.is_inductive_cumulativity; + optwrite = Flags.make_inductive_cumulativity } + +let _ = declare_int_option { optdepr = false; optname = "the level of inlining during functor application"; @@ -1394,17 +1390,6 @@ let _ = optread = (fun () -> !CClosure.share); optwrite = (fun b -> CClosure.share := b) } -(* No more undo limit in the new proof engine. - The command still exists for compatibility (e.g. with ProofGeneral) *) - -let _ = - declare_int_option - { optdepr = true; - optname = "the undo limit (OBSOLETE)"; - optkey = ["Undo"]; - optread = (fun _ -> None); - optwrite = (fun _ -> ()) } - let _ = declare_bool_option { optdepr = false; @@ -1526,7 +1511,7 @@ let vernac_print_option key = with Not_found -> error_undeclared_key key let get_current_context_of_args = function - | Some n -> get_goal_context n + | Some n -> Pfedit.get_goal_context n | None -> get_current_context () let query_command_selector ?loc = function @@ -1588,7 +1573,7 @@ let vernac_global_check c = let get_nth_goal n = - let pf = get_pftreestate() in + let pf = Proof_global.give_me_the_proof() in let {Evd.it=gls ; sigma=sigma; } = Proof.V82.subgoals pf in let gl = {Evd.it=List.nth gls (n-1) ; sigma = sigma; } in gl @@ -1777,7 +1762,7 @@ let vernac_locate = let open Feedback in function | LocateFile f -> msg_notice (locate_file f) let vernac_register id r = - if Pfedit.refining () then + if Proof_global.there_are_pending_proofs () then user_err Pp.(str "Cannot register a primitive while in proof editing mode."); let kn = Constrintern.global_reference (snd id) in if not (isConstRef kn) then @@ -1844,24 +1829,16 @@ let vernac_show = let open Feedback in function | GoalUid id -> pr_goal_by_uid id in msg_notice info - | ShowGoalImplicitly None -> - Constrextern.with_implicits msg_notice (pr_open_subgoals ()) - | ShowGoalImplicitly (Some n) -> - Constrextern.with_implicits msg_notice (pr_nth_open_subgoal n) | ShowProof -> show_proof () - | ShowNode -> show_node () | ShowExistentials -> show_top_evars () | ShowUniverses -> show_universes () - | ShowTree -> show_prooftree () | ShowProofNames -> - msg_notice (pr_sequence pr_id (Pfedit.get_all_proof_names())) + msg_notice (pr_sequence pr_id (Proof_global.get_all_proof_names())) | ShowIntros all -> show_intro all | ShowMatch id -> show_match id - | ShowThesis -> show_thesis () - let vernac_check_guard () = - let pts = get_pftreestate () in + let pts = Proof_global.give_me_the_proof () in let pfterm = List.hd (Proof.partial_proof pts) in let message = try @@ -1964,7 +1941,7 @@ let interp ?proof ?loc locality poly c = | VernacEndProof e -> vernac_end_proof ?proof e | VernacExactProof c -> vernac_exact_proof c | VernacAssumption (stre,nl,l) -> vernac_assumption locality poly stre l nl - | VernacInductive (priv,finite,l) -> vernac_inductive poly priv finite l + | VernacInductive (cum, priv,finite,l) -> vernac_inductive cum poly priv finite l | VernacFixpoint (local, l) -> vernac_fixpoint locality poly local l | VernacCoFixpoint (local, l) -> vernac_cofixpoint locality poly local l | VernacScheme l -> vernac_scheme l |