diff options
290 files changed, 13285 insertions, 8233 deletions
diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 00ccc9f137..caed21f5c3 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -18,7 +18,7 @@ stages: variables: # Format: $IMAGE-V$DATE [Cache is not used as of today but kept here # for reference] - CACHEKEY: "bionic_coq-V2019-03-18-V93" + CACHEKEY: "bionic_coq-V2020-03-27-V12" IMAGE: "$CI_REGISTRY_IMAGE:$CACHEKEY" # By default, jobs run in the base switch; override to select another switch OPAM_SWITCH: "base" @@ -69,6 +69,7 @@ before_script: - _install_ci - config/Makefile - config/coq_config.py + - config/coq_config.ml - test-suite/misc/universes/all_stdlib.v expire_in: 1 week script: @@ -102,6 +103,9 @@ before_script: interruptible: true dependencies: [] script: + # flambda can be pretty stack hungry, specially with -O3 + # See also https://github.com/ocaml/ocaml/issues/7842#issuecomment-596863244 + - ulimit -s 16384 - set -e - make -f Makefile.dune world - set +e @@ -172,7 +176,7 @@ before_script: - BIN=$(readlink -f ../_install_ci/bin)/ - LIB=$(readlink -f ../_install_ci/lib/coq)/ - export OCAMLPATH=$(readlink -f ../_install_ci/lib/):"$OCAMLPATH" - - make -j "$NJOBS" BIN="$BIN" COQLIB="$LIB" COQFLAGS="${COQFLAGS}" all + - COQEXTRAFLAGS="${COQEXTRAFLAGS}" make -j "$NJOBS" BIN="$BIN" COQLIB="$LIB" all artifacts: name: "$CI_JOB_NAME.logs" when: on_failure @@ -425,7 +429,16 @@ doc:refman:dune: artifacts: paths: - _build/log - - _build/default/doc/sphinx_build/html + - _build/default/doc/refman-html + +doc:refman-pdf:dune: + extends: .dune-ci-template + variables: + DUNE_TARGET: refman-pdf + artifacts: + paths: + - _build/log + - _build/default/doc/refman-pdf doc:stdlib:dune: extends: .dune-ci-template @@ -460,7 +473,7 @@ doc:refman:deploy: - rm -rf _deploy/$CI_COMMIT_REF_NAME/stdlib - mkdir -p _deploy/$CI_COMMIT_REF_NAME - cp -rv _build/default/_doc/_html _deploy/$CI_COMMIT_REF_NAME/api - - cp -rv _build/default/doc/sphinx_build/html _deploy/$CI_COMMIT_REF_NAME/refman + - cp -rv _build/default/doc/refman-html _deploy/$CI_COMMIT_REF_NAME/refman - cp -rv _build/default/doc/stdlib/html _deploy/$CI_COMMIT_REF_NAME/stdlib - cd _deploy/$CI_COMMIT_REF_NAME/ - git add api refman stdlib @@ -524,6 +537,30 @@ test-suite:edge:dune:dev: # Gitlab doesn't support yet "expire_in: never" so we use the instance default # expire_in: never +test-suite:edge+4.11+trunk+dune: + stage: stage-1 + dependencies: [] + script: + - opam switch create 4.11.0 --empty + - eval $(opam env) + - opam repo add ocaml-beta https://github.com/ocaml/ocaml-beta-repository.git + - opam update + - opam install ocaml-variants=4.11.0+trunk + - opam install dune num + - eval $(opam env) + - export COQ_UNIT_TEST=noop + - make -f Makefile.dune test-suite + variables: + OPAM_SWITCH: base + artifacts: + name: "$CI_JOB_NAME.logs" + when: always + paths: + - _build/log + - _build/default/test-suite/logs + expire_in: 2 week + allow_failure: true + test-suite:base+async: extends: .test-suite-template dependencies: @@ -531,7 +568,7 @@ test-suite:base+async: needs: - build:base variables: - COQFLAGS: "-async-proofs on -async-proofs-cache force" + COQEXTRAFLAGS: "-async-proofs on -async-proofs-cache force" timeout: 100m allow_failure: true only: @@ -582,6 +619,9 @@ validate:quick: library:ci-argosy: extends: .ci-template +library:ci-bbv: + extends: .ci-template + library:ci-bedrock2: extends: .ci-template-flambda artifacts: @@ -721,10 +761,24 @@ plugin:ci-elpi: plugin:ci-equations: extends: .ci-template + artifacts: + name: "$CI_JOB_NAME" + paths: + - _build_ci plugin:ci-fiat_parsers: extends: .ci-template +plugin:ci-metacoq: + extends: .ci-template + stage: stage-3 + needs: + - build:base + - plugin:ci-equations + dependencies: + - build:base + - plugin:ci-equations + plugin:ci-mtac2: extends: .ci-template diff --git a/.ocamlformat b/.ocamlformat index 59883180e5..4480935e3b 100644 --- a/.ocamlformat +++ b/.ocamlformat @@ -1,7 +1,14 @@ +version=0.13.0 profile=ocamlformat + +# to enable a whole directory, put "disable=false" in dir/.ocamlformat +# to enable specific files put them in .ocamlformat-enable +disable=true + module-item-spacing=compact sequence-style=terminator cases-exp-indent=2 field-space=loose exp-grouping=preserve break-cases=fit +doc-comments=before diff --git a/.ocamlformat-ignore b/.ocamlformat-ignore deleted file mode 100644 index b1f6597140..0000000000 --- a/.ocamlformat-ignore +++ /dev/null @@ -1,53 +0,0 @@ -configure.ml -dev/* -coqpp/* -lib/* -clib/* -config/* -checker/* -kernel/* -library/* -engine/* -gramlib/* -parsing/* -interp/* -pretyping/* -printing/* -proofs/* -stm/* -tactics/* -theories/* -user-contrib/*/* -vernac/* -toplevel/* -topbin/* -ide/* -ide/*/* -doc/plugin_tutorial/*/*/* -doc/tools/docgram/* -test-suite/* -test-suite/*/*/* -test-suite/*/*/*/* -test-suite/*/*/*/*/* -tools/* -tools/*/* -plugins/btauto/* -plugins/cc/* -plugins/derive/* -plugins/extraction/* -plugins/firstorder/* -plugins/fourier/* -plugins/funind/* -plugins/ltac/* -plugins/nsatz/* -plugins/omega/* -plugins/rtauto/* -plugins/setoid/* -plugins/ing/* -plugins/setoid_ring/* -plugins/ssr/* -plugins/ssrmatching/* -plugins/syntax/* -# Enabled: micromega -# plugins/micromega/* -plugins/micromega/micromega.ml diff --git a/INSTALL.md b/INSTALL.md index 0c98a611a5..2397f2c5c2 100644 --- a/INSTALL.md +++ b/INSTALL.md @@ -7,7 +7,7 @@ Build Requirements To compile Coq yourself, you need: - [OCaml](https://ocaml.org/) (version >= 4.05.0) - (This version of Coq has been tested up to OCaml 4.09.1) + (This version of Coq has been tested up to OCaml 4.10.0) - The [num](https://github.com/ocaml/num) library; note that it is included in the OCaml distribution for OCaml versions < 4.06.0 @@ -45,7 +45,7 @@ CoqIDE with: Opam (https://opam.ocaml.org/) is recommended to install OCaml and the corresponding packages. - $ opam switch create coq 4.09.1+flambda + $ opam switch create coq 4.10.0+flambda $ eval $(opam env) $ opam install num ocamlfind lablgtk3-sourceview3 diff --git a/Makefile.ci b/Makefile.ci index dfb3f69a8c..d4383fd409 100644 --- a/Makefile.ci +++ b/Makefile.ci @@ -11,6 +11,7 @@ CI_TARGETS= \ ci-aac_tactics \ ci-argosy \ + ci-bbv \ ci-bedrock2 \ ci-bignums \ ci-color \ @@ -33,6 +34,7 @@ CI_TARGETS= \ ci-iris-lambda-rust \ ci-math-classes \ ci-math-comp \ + ci-metacoq \ ci-mtac2 \ ci-paramcoq \ ci-perennial \ @@ -72,6 +74,8 @@ ci-fiat-crypto: ci-coqprime ci-rewriter ci-simple-io: ci-ext-lib ci-quickchick: ci-ext-lib ci-simple-io +ci-metacoq: ci-equations + # Generic rule, we use make to ease CI integration $(CI_TARGETS): ci-%: +./dev/ci/ci-wrapper.sh $* diff --git a/Makefile.doc b/Makefile.doc index a8703b0acf..9da175f0e5 100644 --- a/Makefile.doc +++ b/Makefile.doc @@ -246,16 +246,16 @@ $(DOC_GRAM): $(DOC_GRAMCMO) coqpp/coqpp_parser.mli coqpp/coqpp_parser.ml doc/too # user-contrib/*/*.mlg omitted for now (e.g. ltac2) PLUGIN_MLGS := $(wildcard plugins/*/*.mlg) OMITTED_PLUGIN_MLGS := plugins/ssr/ssrparser.mlg plugins/ssr/ssrvernac.mlg plugins/ssrmatching/g_ssrmatching.mlg -DOC_MLGS := */*.mlg $(sort $(filter-out $(OMITTED_PLUGIN_MLGS), $(PLUGIN_MLGS))) -DOC_EDIT_MLGS := doc/tools/docgram/*.edit_mlg -DOC_RSTS := doc/sphinx/*/*.rst +DOC_MLGS := $(wildcard */*.mlg) $(sort $(filter-out $(OMITTED_PLUGIN_MLGS), $(PLUGIN_MLGS))) +DOC_EDIT_MLGS := $(wildcard doc/tools/docgram/*.edit_mlg) +DOC_RSTS := $(wildcard doc/sphinx/*/*.rst) doc/tools/docgram/fullGrammar: $(DOC_GRAM) $(DOC_MLGS) $(SHOW)'DOC_GRAM' $(HIDE)$(DOC_GRAM) -short -no-warn $(DOC_MLGS) #todo: add a dependency of sphinx on updated_rsts when we're ready -doc/tools/docgram/orderedGrammar doc/tools/docgram/updated_rsts: $(DOC_GRAM) $(DOC_EDIT_MLGS) +doc/tools/docgram/orderedGrammar doc/tools/docgram/updated_rsts: doc/tools/docgram/fullGrammar $(DOC_GRAM) $(DOC_EDIT_MLGS) $(SHOW)'DOC_GRAM_RSTS' $(HIDE)$(DOC_GRAM) -check-cmds $(DOC_MLGS) $(DOC_RSTS) diff --git a/Makefile.dune b/Makefile.dune index b433ed1b94..b77e78db69 100644 --- a/Makefile.dune +++ b/Makefile.dune @@ -4,7 +4,7 @@ .PHONY: help voboot states world watch check # Main developer targets .PHONY: coq coqide coqide-server # Package targets .PHONY: quickbyte quickopt quickide # Partial / quick developer targets -.PHONY: refman-html stdlib-html apidoc # Documentation targets +.PHONY: refman-html refman-pdf stdlib-html apidoc # Documentation targets .PHONY: test-suite release # Accessory targets .PHONY: fmt ocheck ireport clean # Maintenance targets @@ -32,6 +32,7 @@ help: @echo "" @echo " - test-suite: run Coq's test suite" @echo " - refman-html: build Coq's reference manual [HTML version]" + @echo " - refman-pdf: build Coq's reference manual [PDF version]" @echo " - stdlib-html: build Coq's Stdlib documentation [HTML version]" @echo " - apidoc: build ML API documentation" @echo " - release: build Coq in release mode" @@ -53,8 +54,10 @@ voboot: plugins/ltac/dune states: voboot dune build --display=short $(DUNEOPT) dev/shim/coqtop-prelude +NONDOC_INSTALL_TARGETS:=coq.install coqide-server.install coqide.install + world: voboot - dune build $(DUNEOPT) @install + dune build $(DUNEOPT) $(NONDOC_INSTALL_TARGETS) coq: voboot dune build $(DUNEOPT) coq.install @@ -66,7 +69,7 @@ coqide-server: voboot dune build $(DUNEOPT) coqide-server.install watch: voboot - dune build $(DUNEOPT) @install -w + dune build $(DUNEOPT) $(NONDOC_INSTALL_TARGETS) -w check: voboot dune build $(DUNEOPT) @check @@ -92,6 +95,9 @@ test-suite: voboot refman-html: voboot dune build @refman-html +refman-pdf: voboot + dune build @refman-pdf + stdlib-html: voboot dune build @stdlib-html @@ -102,7 +108,7 @@ release: voboot dune build $(DUNEOPT) -p coq fmt: voboot - dune build @fmt + dune build @fmt --auto-promote ocheck: voboot dune build $(DUNEOPT) @install --workspace=dev/dune-workspace.all diff --git a/azure-pipelines.yml b/azure-pipelines.yml index aae2c3cb42..0bc30f0196 100644 --- a/azure-pipelines.yml +++ b/azure-pipelines.yml @@ -72,7 +72,7 @@ jobs: opam list displayName: 'Install OCaml dependencies' env: - COMPILER: "4.09.1" + COMPILER: "4.10.0" FINDLIB_VER: ".1.8.1" OPAMYES: "true" diff --git a/configure.ml b/configure.ml index 55d71f6c2e..eaa0e321b0 100644 --- a/configure.ml +++ b/configure.ml @@ -616,8 +616,9 @@ let camltag = match caml_version_list with 45: "open" shadowing a label or constructor: see 44 48: implicit elimination of optional arguments: too common 58: "no cmx file was found in path": See https://github.com/ocaml/num/issues/9 + 67: "unused functor parameter" seems totally bogus *) -let coq_warnings = "-w +a-4-9-27-41-42-44-45-48-58" +let coq_warnings = "-w +a-4-9-27-41-42-44-45-48-58-67" let coq_warn_error = if !prefs.warn_error then "-warn-error +a" @@ -923,7 +924,11 @@ let datadir,datadirsuffix = let (_,_,d,s) = select "DATADIR" in d,s (** * CC runtime flags *) -let cflags_dflt = "-Wall -Wno-unused -g -O2 -std=c99 -fasm" +(* Note that Coq's VM requires at least C99-compliant floating-point + arithmetic; this should be ensured by OCaml's own C flags, which + set a minimum of [--std=gnu99] ; modern compilers by default assume + C11 or later, so no explicit [--std=] flags are added by OCaml *) +let cflags_dflt = "-Wall -Wno-unused -g -O2" let cflags_sse2 = "-msse2 -mfpmath=sse" diff --git a/coq-refman.opam b/coq-doc.opam index 937c4b08d3..2f4072955f 100644 --- a/coq-refman.opam +++ b/coq-doc.opam @@ -27,7 +27,7 @@ build-env: [ ] build: [ - [ "dune" "build" "@refman" "-j" jobs ] + [ "dune" "build" "-p" name "-j" jobs ] ] # Would be better to have a *-conf package? diff --git a/coq.opam.docker b/coq.opam.docker new file mode 100644 index 0000000000..229a47a87b --- /dev/null +++ b/coq.opam.docker @@ -0,0 +1,38 @@ +synopsis: "The Coq Proof Assistant" +description: """ +Coq is a formal proof management system. It provides +a formal language to write mathematical definitions, executable +algorithms and theorems together with an environment for +semi-interactive development of machine-checked proofs. Typical +applications include the certification of properties of programming +languages (e.g. the CompCert compiler certification project, or the +Bedrock verified low-level programming library), the formalization of +mathematics (e.g. the full formalization of the Feit-Thompson theorem +or homotopy type theory) and teaching. +""" +opam-version: "2.0" +maintainer: "The Coq development team <coqdev@inria.fr>" +authors: "The Coq development team, INRIA, CNRS, and contributors." +homepage: "https://coq.inria.fr/" +bug-reports: "https://github.com/coq/coq/issues" +dev-repo: "git+https://github.com/coq/coq.git" +license: "LGPL-2.1" + +version: "dev" + +depends: [ + "ocaml" { >= "4.05.0" } + "ocamlfind" { build } + "num" + "conf-findutils" {build} +] + +build: [ + [ "./configure" "-prefix" prefix "-coqide" "no" ] + [make "-j%{jobs}%"] + [make "-j%{jobs}%" "byte"] +] +install: [ + [make "install"] + [make "install-byte"] +] diff --git a/coqpp/coqpp_main.ml b/coqpp/coqpp_main.ml index bdffabf0b2..43cd6f1784 100644 --- a/coqpp/coqpp_main.ml +++ b/coqpp/coqpp_main.ml @@ -115,7 +115,7 @@ let print_local fmt ext = match locals with | [] -> () | e :: locals -> - let mk_e fmt e = fprintf fmt "Pcoq.Entry.create \"%s\"" e in + let mk_e fmt e = fprintf fmt "Pcoq.Entry.make \"%s\"" e in let () = fprintf fmt "@[<hv 2>let %s =@ @[%a@]@]@ " e mk_e e in let iter e = fprintf fmt "@[<hv 2>and %s =@ @[%a@]@]@ " e mk_e e in let () = List.iter iter locals in @@ -217,43 +217,43 @@ let rec print_prod fmt p = and print_extrule fmt (tkn, vars, body) = let tkn = List.rev tkn in - fprintf fmt "@[Extend.Rule@ (@[%a@],@ @[(%a)@])@]" (print_symbols ~norec:false) tkn print_fun (vars, body) + fprintf fmt "@[Pcoq.Production.make@ @[(%a)@]@ @[(%a)@]@]" (print_symbols ~norec:false) tkn print_fun (vars, body) and print_symbols ~norec fmt = function -| [] -> fprintf fmt "Extend.Stop" +| [] -> fprintf fmt "Pcoq.Rule.stop" | tkn :: tkns -> - let c = if norec then "Extend.NextNoRec" else "Extend.Next" in - fprintf fmt "%s @[(%a,@ %a)@]" c (print_symbols ~norec) tkns print_symbol tkn + let c = if norec then "Pcoq.Rule.next_norec" else "Pcoq.Rule.next" in + fprintf fmt "%s @[(%a)@ (%a)@]" c (print_symbols ~norec) tkns print_symbol tkn and print_symbol fmt tkn = match tkn with | SymbToken (t, s) -> - fprintf fmt "(Extend.Atoken (%a))" print_tok (t, s) + fprintf fmt "(Pcoq.Symbol.token (%a))" print_tok (t, s) | SymbEntry (e, None) -> - fprintf fmt "(Extend.Aentry %s)" e + fprintf fmt "(Pcoq.Symbol.nterm %s)" e | SymbEntry (e, Some l) -> - fprintf fmt "(Extend.Aentryl (%s, %a))" e print_string l + fprintf fmt "(Pcoq.Symbol.nterml %s (%a))" e print_string l | SymbSelf -> - fprintf fmt "Extend.Aself" + fprintf fmt "Pcoq.Symbol.self" | SymbNext -> - fprintf fmt "Extend.Anext" + fprintf fmt "Pcoq.Symbol.next" | SymbList0 (s, None) -> - fprintf fmt "(Extend.Alist0 %a)" print_symbol s + fprintf fmt "(Pcoq.Symbol.list0 %a)" print_symbol s | SymbList0 (s, Some sep) -> - fprintf fmt "(Extend.Alist0sep (%a, %a))" print_symbol s print_symbol sep + fprintf fmt "(Pcoq.Symbol.list0sep (%a) (%a) false)" print_symbol s print_symbol sep | SymbList1 (s, None) -> - fprintf fmt "(Extend.Alist1 %a)" print_symbol s + fprintf fmt "(Pcoq.Symbol.list1 (%a))" print_symbol s | SymbList1 (s, Some sep) -> - fprintf fmt "(Extend.Alist1sep (%a, %a))" print_symbol s print_symbol sep + fprintf fmt "(Pcoq.Symbol.list1sep (%a) (%a) false)" print_symbol s print_symbol sep | SymbOpt s -> - fprintf fmt "(Extend.Aopt %a)" print_symbol s + fprintf fmt "(Pcoq.Symbol.opt %a)" print_symbol s | SymbRules rules -> let pr fmt (r, body) = let (vars, tkn) = List.split r in let tkn = List.rev tkn in - fprintf fmt "Extend.Rules @[(%a,@ (%a))@]" (print_symbols ~norec:true) tkn print_fun (vars, body) + fprintf fmt "Pcoq.Rules.make @[(%a)@ (%a)@]" (print_symbols ~norec:true) tkn print_fun (vars, body) in let pr fmt rules = print_list fmt pr rules in - fprintf fmt "(Extend.Arules %a)" pr (List.rev rules) + fprintf fmt "(Pcoq.Symbol.rules %a)" pr (List.rev rules) | SymbQuote c -> fprintf fmt "(%s)" c @@ -266,7 +266,7 @@ let print_rule fmt r = let print_entry fmt e = let print_position_opt fmt pos = print_opt fmt print_position pos in let print_rules fmt rules = print_list fmt print_rule rules in - fprintf fmt "let () =@ @[Pcoq.grammar_extend@ %s@ @[(%a, %a)@]@]@ in@ " + fprintf fmt "let () =@ @[Pcoq.grammar_extend@ %s@ @[{ Pcoq.pos=%a; data=%a}@]@]@ in@ " e.gentry_name print_position_opt e.gentry_pos print_rules e.gentry_rules let print_ast fmt ext = @@ -452,7 +452,7 @@ let terminal s = let p = if s <> "" && s.[0] >= '0' && s.[0] <= '9' then "CLexer.terminal_numeral" else "CLexer.terminal" in - let c = Printf.sprintf "Extend.Atoken (%s \"%s\")" p s in + let c = Printf.sprintf "Pcoq.Symbol.token (%s \"%s\")" p s in SymbQuote c let rec parse_symb self = function diff --git a/dev/ci/azure-opam.sh b/dev/ci/azure-opam.sh index 7b3e2703b8..64936cd236 100755 --- a/dev/ci/azure-opam.sh +++ b/dev/ci/azure-opam.sh @@ -2,7 +2,7 @@ set -e -x -OPAM_VARIANT=ocaml-variants.4.09.1+mingw64c +OPAM_VARIANT=ocaml-variants.4.10.0+mingw64c wget https://github.com/fdopen/opam-repository-mingw/releases/download/0.0.0.2/opam64.tar.xz -O opam64.tar.xz tar -xf opam64.tar.xz diff --git a/dev/ci/ci-basic-overlay.sh b/dev/ci/ci-basic-overlay.sh index bd7ee46358..c18e556da8 100755 --- a/dev/ci/ci-basic-overlay.sh +++ b/dev/ci/ci-basic-overlay.sh @@ -200,6 +200,13 @@ : "${coqprime_CI_ARCHIVEURL:=${coqprime_CI_GITURL}/archive}" ######################################################################## +# bbv +######################################################################## +: "${bbv_CI_REF:=master}" +: "${bbv_CI_GITURL:=https://github.com/mit-plv/bbv}" +: "${bbv_CI_ARCHIVEURL:=${bbv_CI_GITURL}/archive}" + +######################################################################## # bedrock2 ######################################################################## : "${bedrock2_CI_REF:=tested}" @@ -330,3 +337,10 @@ : "${perennial_CI_REF:=master}" : "${perennial_CI_GITURL:=https://github.com/mit-pdos/perennial}" : "${perennial_CI_ARCHIVEURL:=${perennial_CI_GITURL}/archive}" + +######################################################################## +# metacoq +######################################################################## +: "${metacoq_CI_REF:=master}" +: "${metacoq_CI_GITURL:=https://github.com/MetaCoq/metacoq}" +: "${metacoq_CI_ARCHIVEURL:=${metacoq_CI_GITURL}/archive}" diff --git a/dev/ci/ci-bbv.sh b/dev/ci/ci-bbv.sh new file mode 100755 index 0000000000..6892cea3e4 --- /dev/null +++ b/dev/ci/ci-bbv.sh @@ -0,0 +1,8 @@ +#!/usr/bin/env bash + +ci_dir="$(dirname "$0")" +. "${ci_dir}/ci-common.sh" + +git_download bbv + +( cd "${CI_BUILD_DIR}/bbv" && make && make install ) diff --git a/dev/ci/ci-equations.sh b/dev/ci/ci-equations.sh index 871d033f5b..30047e624b 100755 --- a/dev/ci/ci-equations.sh +++ b/dev/ci/ci-equations.sh @@ -5,4 +5,4 @@ ci_dir="$(dirname "$0")" git_download equations -( cd "${CI_BUILD_DIR}/equations" && ./configure.sh coq && make ci) +( cd "${CI_BUILD_DIR}/equations" && ./configure.sh coq && make ci && make install ) diff --git a/dev/ci/ci-metacoq.sh b/dev/ci/ci-metacoq.sh new file mode 100755 index 0000000000..1302065961 --- /dev/null +++ b/dev/ci/ci-metacoq.sh @@ -0,0 +1,8 @@ +#!/usr/bin/env bash + +ci_dir="$(dirname "$0")" +. "${ci_dir}/ci-common.sh" + +git_download metacoq + +( cd "${CI_BUILD_DIR}/metacoq" && ./configure.sh local && make ci-local && make install ) diff --git a/dev/ci/docker/bionic_coq/Dockerfile b/dev/ci/docker/bionic_coq/Dockerfile index 4e229bb777..0c8733c75a 100644 --- a/dev/ci/docker/bionic_coq/Dockerfile +++ b/dev/ci/docker/bionic_coq/Dockerfile @@ -1,4 +1,4 @@ -# CACHEKEY: "bionic_coq-V2019-03-18-V93" +# CACHEKEY: "bionic_coq-V2020-03-27-V12" # ^^ Update when modifying this file. FROM ubuntu:bionic @@ -18,7 +18,7 @@ RUN apt-get update -qq && apt-get install --no-install-recommends -y -qq \ texlive-science tipa # More dependencies of the sphinx doc -RUN pip3 install sphinx==1.7.8 sphinx_rtd_theme==0.2.5b2 \ +RUN pip3 install sphinx==1.8.0 sphinx_rtd_theme==0.2.5b2 \ antlr4-python3-runtime==4.7.1 sphinxcontrib-bibtex==0.4.0 # We need to install OPAM 2.0 manually for now. @@ -56,8 +56,8 @@ RUN opam switch create "${COMPILER}+32bit" && eval $(opam env) && \ opam install $BASE_OPAM # EDGE switch -ENV COMPILER_EDGE="4.09.1" \ - BASE_OPAM_EDGE="dune-release.1.3.3 ocamlformat.0.12" +ENV COMPILER_EDGE="4.10.0" \ + BASE_OPAM_EDGE="dune-release.1.3.3 ocamlformat.0.13.0" # EDGE+flambda switch, we install CI_OPAM as to be able to use # `ci-template-flambda` with everything. diff --git a/dev/ci/user-overlays/11703-herbelin-master+turning-numTok-into-a-numeral-API.sh b/dev/ci/user-overlays/11703-herbelin-master+turning-numTok-into-a-numeral-API.sh new file mode 100644 index 0000000000..8a734feada --- /dev/null +++ b/dev/ci/user-overlays/11703-herbelin-master+turning-numTok-into-a-numeral-API.sh @@ -0,0 +1,6 @@ +if [ "$CI_PULL_REQUEST" = "11703" ] || [ "$CI_BRANCH" = "master+turning-numTok-into-a-numeral-API" ]; then + + quickchick_CI_REF=master+adapting-numTok-new-api-pr11703 + quickchick_CI_GITURL=https://github.com/herbelin/QuickChick + +fi diff --git a/dev/ci/user-overlays/11731-ejgallego-proof+more_naming_unif.sh b/dev/ci/user-overlays/11731-ejgallego-proof+more_naming_unif.sh new file mode 100644 index 0000000000..6928925e54 --- /dev/null +++ b/dev/ci/user-overlays/11731-ejgallego-proof+more_naming_unif.sh @@ -0,0 +1,12 @@ +if [ "$CI_PULL_REQUEST" = "11731" ] || [ "$CI_BRANCH" = "proof+more_naming_unif" ]; then + + equations_CI_REF=proof+more_naming_unif + equations_CI_GITURL=https://github.com/ejgallego/Coq-Equations + + rewriter_CI_REF=proof+more_naming_unif + rewriter_CI_GITURL=https://github.com/ejgallego/rewriter + + elpi_CI_REF=proof+more_naming_unif + elpi_CI_GITURL=https://github.com/ejgallego/coq-elpi + +fi diff --git a/dev/ci/user-overlays/11818-ejgallego-proof+remove_special_case_first_declaration_in_mutual.sh b/dev/ci/user-overlays/11818-ejgallego-proof+remove_special_case_first_declaration_in_mutual.sh new file mode 100644 index 0000000000..e3a8eb07f3 --- /dev/null +++ b/dev/ci/user-overlays/11818-ejgallego-proof+remove_special_case_first_declaration_in_mutual.sh @@ -0,0 +1,15 @@ +if [ "$CI_PULL_REQUEST" = "11818" ] || [ "$CI_BRANCH" = "proof+remove_special_case_first_declaration_in_mutual" ]; then + + metacoq_CI_REF=proof+remove_special_case_first_declaration_in_mutual + metacoq_CI_GITURL=https://github.com/ejgallego/metacoq + + elpi_CI_REF=proof+remove_special_case_first_declaration_in_mutual + elpi_CI_GITURL=https://github.com/ejgallego/coq-elpi + + paramcoq_CI_REF=proof+remove_special_case_first_declaration_in_mutual + paramcoq_CI_GITURL=https://github.com/ejgallego/paramcoq + + equations_CI_REF=proof+remove_special_case_first_declaration_in_mutual + equations_CI_GITURL=https://github.com/ejgallego/Coq-Equations + +fi diff --git a/dev/doc/changes.md b/dev/doc/changes.md index 9088df6856..eac8d86b0a 100644 --- a/dev/doc/changes.md +++ b/dev/doc/changes.md @@ -1,19 +1,21 @@ ## Changes between Coq 8.11 and Coq 8.12 -### ML API +### Code formatting -Refiner.catchable_exception is deprecated, use instead -CErrors.noncritical in try-with block. Note that nothing is needed in -tclORELSE block since the exceptions there are supposed to be -non-critical by construction. +- The automatic code formatting tool `ocamlformat` is enabled now for + the micromega codebase. Version 0.13.0 is required. See + `ocalmformat`'s documentation for more details on integration with + your editor. ### ML API -Types `precedence`, `parenRelation`, `tolerability` in -`notgram_ops.ml` have been reworked. See `entry_level` and -`entry_relative_level` in `constrexpr.ml`. +Notations: -### ML API +- Most operators on numerals have moved to file numTok.ml. + +- Types `precedence`, `parenRelation`, `tolerability` in + `notgram_ops.ml` have been reworked. See `entry_level` and + `entry_relative_level` in `constrexpr.ml`. Exception handling: @@ -28,6 +30,11 @@ Exception handling: + printers are of type `exn -> Pp.t option` [`None` == not handled] + it is forbidden for exception printers to raise. +- Refiner.catchable_exception is deprecated, use instead + CErrors.noncritical in try-with block. Note that nothing is needed in + tclORELSE block since the exceptions there are supposed to be + non-critical by construction. + Printers: - Functions such as Printer.pr_lconstr_goal_style_env have been diff --git a/dev/dune-workspace.all b/dev/dune-workspace.all index 556493ffad..d6348a3624 100644 --- a/dev/dune-workspace.all +++ b/dev/dune-workspace.all @@ -3,5 +3,5 @@ ; Add custom flags here. Default developer profile is `dev` (context (opam (switch 4.05.0))) (context (opam (switch 4.05.0+32bit))) -(context (opam (switch 4.09.1))) -(context (opam (switch 4.09.1+flambda))) +(context (opam (switch 4.10.0))) +(context (opam (switch 4.10.0+flambda))) diff --git a/dev/tools/pre-commit b/dev/tools/pre-commit index ad2f2f93e7..633913aac6 100755 --- a/dev/tools/pre-commit +++ b/dev/tools/pre-commit @@ -7,69 +7,75 @@ set -e dev/tools/check-overlays.sh -if ! git diff --cached --name-only -z | xargs -0 dev/tools/check-eof-newline.sh || - ! git diff-index --check --cached HEAD >/dev/null 2>&1 ; +# Can we check and fix formatting? +# NB: we will ignore errors from ocamlformat as it fails when +# encountering OCaml syntax errors +ocamlformat=$(command -v ocamlformat || echo true) +if [ "$ocamlformat" = true ] then - 1>&2 echo "Auto fixing whitespace issues..." + 1>&2 echo "Warning: ocamlformat is not in path. Cannot check formatting." +fi - # We fix whitespace in the index and in the working tree - # separately to preserve non-added changes. - index=$(mktemp "git-fix-ws-index.XXXXXX") - fixed_index=$(mktemp "git-fix-ws-index-fixed.XXXXXX") - tree=$(mktemp "git-fix-ws-tree.XXXXXX") - 1>&2 echo "Patches are saved in '$index', '$fixed_index' and '$tree'." - 1>&2 echo "If an error destroys your changes you can recover using them." - 1>&2 echo "(The files are cleaned up on success.)" - 1>&2 echo #newline +1>&2 echo "Auto fixing whitespace and formatting issues..." - git diff-index -p --cached HEAD > "$index" - git diff-index -p HEAD > "$tree" +# We fix whitespace in the index and in the working tree +# separately to preserve non-added changes. +index=$(mktemp "git-fix-ws-index.XXXXXX") +fixed_index=$(mktemp "git-fix-ws-index-fixed.XXXXXX") +tree=$(mktemp "git-fix-ws-tree.XXXXXX") +1>&2 echo "Patches are saved in '$index', '$fixed_index' and '$tree'." +1>&2 echo "If an error destroys your changes you can recover using them." +1>&2 echo "(The files are cleaned up on success.)" +1>&2 echo #newline - # reset work tree and index - # NB: untracked files which were not added are untouched - git apply --whitespace=nowarn --cached -R "$index" - git apply --whitespace=nowarn -R "$tree" +git diff-index -p --cached HEAD > "$index" +git diff-index -p HEAD > "$tree" - # Fix index - # For end of file newlines we must go through the worktree +# reset work tree and index +# NB: untracked files which were not added are untouched +if [ -s "$index" ]; then git apply --whitespace=nowarn --cached -R "$index"; fi +if [ -s "$tree" ]; then git apply --whitespace=nowarn -R "$tree"; fi + +# Fix index +# For end of file newlines we must go through the worktree +if [ -s "$index" ]; then 1>&2 echo "Fixing staged changes..." git apply --cached --whitespace=fix "$index" git apply --whitespace=fix "$index" 2>/dev/null # no need to repeat yourself git diff --cached --name-only -z | xargs -0 dev/tools/check-eof-newline.sh --fix + git diff --cached --name-only -z | grep -E '.*\.mli?$' -z | xargs -0 "$ocamlformat" -i || true git add -u 1>&2 echo #newline +fi - # reset work tree - git diff-index -p --cached HEAD > "$fixed_index" - # If all changes were bad whitespace changes the patch is empty - # making git fail. Don't fail now: we fix the worktree first. - if [ -s "$fixed_index" ] - then - git apply --whitespace=nowarn -R "$fixed_index" - fi +# reset work tree +git diff-index -p --cached HEAD > "$fixed_index" +# If all changes were bad whitespace changes the patch is empty +# making git fail. Don't fail now: we fix the worktree first. +if [ -s "$fixed_index" ]; then git apply --whitespace=nowarn -R "$fixed_index"; fi - # Fix worktree +# Fix worktree +if [ -s "$tree" ]; then 1>&2 echo "Fixing unstaged changes..." git apply --whitespace=fix "$tree" git diff --name-only -z | xargs -0 dev/tools/check-eof-newline.sh --fix + git diff --name-only -z | grep -E '.*\.mli?$' -z | xargs -0 "$ocamlformat" -i || true 1>&2 echo #newline +fi - if ! [ -s "$fixed_index" ] - then - 1>&2 echo "No changes after fixing whitespace issues!" - exit 1 - fi - - # Check that we did fix whitespace - if ! git diff-index --check --cached HEAD; - then - 1>&2 echo "Auto-fixing whitespace failed: errors remain." - 1>&2 echo "This may fix itself if you try again." - 1>&2 echo "(Consider whether the number of errors decreases after each run.)" - exit 1 - fi - 1>&2 echo "Whitespace issues fixed!" +if [ -s "$index" ] && ! [ -s "$fixed_index" ]; then + 1>&2 echo "Fixing whitespace and formatting issues cancelled all changes." + exit 1 +fi - # clean up temporary files - rm "$index" "$tree" "$fixed_index" +# Check that we did fix whitespace +if ! git diff-index --check --cached HEAD; then + 1>&2 echo "Auto-fixing whitespace failed: errors remain." + 1>&2 echo "This may fix itself if you try again." + 1>&2 echo "(Consider whether the number of errors decreases after each run.)" + exit 1 fi +1>&2 echo "Whitespace and formatting pass complete." + +# clean up temporary files +rm "$index" "$tree" "$fixed_index" diff --git a/dev/top_printers.dbg b/dev/top_printers.dbg index da224aa5ab..06db787488 100644 --- a/dev/top_printers.dbg +++ b/dev/top_printers.dbg @@ -24,6 +24,8 @@ install_printer Top_printers.ppglob_constr install_printer Top_printers.pppattern install_printer Top_printers.ppfconstr install_printer Top_printers.ppbigint +install_printer Top_printers.ppnumtokunsigned +install_printer Top_printers.ppnumtokunsignednat install_printer Top_printers.ppintset install_printer Top_printers.ppidset install_printer Top_printers.ppidmapgen diff --git a/dev/top_printers.ml b/dev/top_printers.ml index 96dbf9142b..7002cbffac 100644 --- a/dev/top_printers.ml +++ b/dev/top_printers.ml @@ -86,6 +86,8 @@ let pptype = (fun x -> try pp(envpp (fun env evm t -> pr_ltype_env env evm t) x) let ppfconstr c = ppconstr (CClosure.term_of_fconstr c) let ppbigint n = pp (str (Bigint.to_string n));; +let ppnumtokunsigned n = pp (NumTok.Unsigned.print n) +let ppnumtokunsignednat n = pp (NumTok.UnsignedNat.print n) let prset pr l = str "[" ++ hov 0 (prlist_with_sep spc pr l) ++ str "]" let ppintset l = pp (prset int (Int.Set.elements l)) diff --git a/dev/top_printers.mli b/dev/top_printers.mli index c5f97f5873..c826391cac 100644 --- a/dev/top_printers.mli +++ b/dev/top_printers.mli @@ -54,6 +54,8 @@ val pppattern : Pattern.constr_pattern -> unit val ppfconstr : CClosure.fconstr -> unit val ppbigint : Bigint.bigint -> unit +val ppnumtokunsigned : NumTok.Unsigned.t -> unit +val ppnumtokunsignednat : NumTok.UnsignedNat.t -> unit val ppintset : Int.Set.t -> unit val ppidset : Names.Id.Set.t -> unit diff --git a/doc/README.md b/doc/README.md index 7fa6f5cf3d..e749bcf5d1 100644 --- a/doc/README.md +++ b/doc/README.md @@ -30,7 +30,7 @@ To produce the complete documentation in HTML, you will need Coq dependencies listed in [`INSTALL.md`](../INSTALL.md). Additionally, the Sphinx-based reference manual requires Python 3, and the following Python packages: - - sphinx >= 1.7.8 + - sphinx >= 1.8.0 - sphinx_rtd_theme >= 0.2.5b2 - beautifulsoup4 >= 4.0.6 - antlr4-python3-runtime >= 4.7.1 diff --git a/doc/changelog/02-specification-language/11098-master+arguments-supports-anonymous-implicit.rst b/doc/changelog/02-specification-language/11098-master+arguments-supports-anonymous-implicit.rst index 633bb6731e..70c57c718f 100644 --- a/doc/changelog/02-specification-language/11098-master+arguments-supports-anonymous-implicit.rst +++ b/doc/changelog/02-specification-language/11098-master+arguments-supports-anonymous-implicit.rst @@ -1,6 +1,6 @@ - **Added:** - :cmd:`Arguments <Arguments (implicits)>` now supports setting - implicit an anonymous argument, as e.g. in :g:`Arguments id {A} {_}` + :cmd:`Arguments` now supports setting + implicit an anonymous argument, as e.g. in :g:`Arguments id {A} {_}`. (`#11098 <https://github.com/coq/coq/pull/11098>`_, by Hugo Herbelin, fixes `#4696 <https://github.com/coq/coq/pull/4696>`_, `#5173 diff --git a/doc/changelog/02-specification-language/11235-non_maximal_implicit.rst b/doc/changelog/02-specification-language/11235-non_maximal_implicit.rst index d8ff1fec31..67e43973ce 100644 --- a/doc/changelog/02-specification-language/11235-non_maximal_implicit.rst +++ b/doc/changelog/02-specification-language/11235-non_maximal_implicit.rst @@ -1,6 +1,6 @@ - **Added:** Syntax for non maximal implicit arguments in definitions and terms using square brackets. The syntax is ``[x : A]``, ``[x]``, ```[A]`` - to be consistent with the command :cmd:`Arguments (implicits)`. + to be consistent with the command :cmd:`Arguments`. (`#11235 <https://github.com/coq/coq/pull/11235>`_, by SimonBoulier). diff --git a/doc/changelog/02-specification-language/11368-trailing_implicit_error.rst b/doc/changelog/02-specification-language/11368-trailing_implicit_error.rst index b0e658998b..11d7218ed0 100644 --- a/doc/changelog/02-specification-language/11368-trailing_implicit_error.rst +++ b/doc/changelog/02-specification-language/11368-trailing_implicit_error.rst @@ -1,6 +1,6 @@ - **Changed:** The warning raised when a trailing implicit is declared to be non maximally - inserted (with the command :cmd:`Arguments <Arguments (implicits)>`) has been turned into an error. + inserted (with the command :cmd:`Arguments`) has been turned into an error. This was deprecated since Coq 8.10 (`#11368 <https://github.com/coq/coq/pull/11368>`_, by SimonBoulier). diff --git a/doc/changelog/03-notations/11848-nicer-decimal-printing.rst b/doc/changelog/03-notations/11848-nicer-decimal-printing.rst new file mode 100644 index 0000000000..1d3a390f36 --- /dev/null +++ b/doc/changelog/03-notations/11848-nicer-decimal-printing.rst @@ -0,0 +1,5 @@ +- **Changed:** + Nicer printing for decimal constants in R and Q. + 1.5 is now printed 1.5 rather than 15e-1. + (`#11848 <https://github.com/coq/coq/pull/11848>`_, + by Pierre Roux). diff --git a/doc/changelog/03-notations/11859-warn-inexact-float.rst b/doc/changelog/03-notations/11859-warn-inexact-float.rst new file mode 100644 index 0000000000..224ffdbe9b --- /dev/null +++ b/doc/changelog/03-notations/11859-warn-inexact-float.rst @@ -0,0 +1,6 @@ +- **Added:** + In primitive floats, print a warning when parsing a decimal value + that is not exactly a binary64 floating-point number. + For instance, parsing 0.1 will print a warning whereas parsing 0.5 won't. + (`#11859 <https://github.com/coq/coq/pull/11859>`_, + by Pierre Roux). diff --git a/doc/changelog/04-tactics/11018-lia-in-auto-with-zarith.rst b/doc/changelog/04-tactics/11018-lia-in-auto-with-zarith.rst new file mode 100644 index 0000000000..d510416990 --- /dev/null +++ b/doc/changelog/04-tactics/11018-lia-in-auto-with-zarith.rst @@ -0,0 +1,7 @@ +- **Changed:** The :g:`auto with zarith` tactic and variations (including :tacn:`intuition`) + may now call the :tacn:`lia` tactic instead of :tacn:`omega` + (when the `Omega` module is loaded); + more goals may be automatically solved, + fewer section variables will be captured spuriously + (`#11018 <https://github.com/coq/coq/pull/11018>`_, + by Vincent Laporte). diff --git a/doc/changelog/04-tactics/11362-micromega-fix-11191.rst b/doc/changelog/04-tactics/11362-micromega-fix-11191.rst index 79879c78d5..20d48929f2 100644 --- a/doc/changelog/04-tactics/11362-micromega-fix-11191.rst +++ b/doc/changelog/04-tactics/11362-micromega-fix-11191.rst @@ -1,5 +1,8 @@ - **Fixed:** - Regression of :tacn:`lia` due to more powerful :tacn:`zify` + :tacn:`zify` now handles :g:`Z.pow_pos` by default. + In Coq 8.11, this was the case only when loading module + :g:`ZifyPow` because this triggered a regression of :tacn:`lia`. + The regression is now fixed, and the module kept only for compatibility (`#11362 <https://github.com/coq/coq/pull/11362>`_, fixes `#11191 <https://github.com/coq/coq/issues/11191>`_, by Frédéric Besson). diff --git a/doc/changelog/04-tactics/11760-firstorder-leaf.rst b/doc/changelog/04-tactics/11760-firstorder-leaf.rst new file mode 100644 index 0000000000..e6e4b827e5 --- /dev/null +++ b/doc/changelog/04-tactics/11760-firstorder-leaf.rst @@ -0,0 +1,9 @@ +- **Changed:** + The default tactic used by :g:`firstorder` is + :g:`auto with core` instead of :g:`auto with *`; + see :ref:`decisionprocedures` for details; + old behavior can be reset by using the `-compat 8.12` command-line flag; + to ease the migration of legacy code, the default solver can be set to `debug auto with *` + with `Set Firstorder Solver debug auto with *` + (`#11760 <https://github.com/coq/coq/pull/11760>`_, + by Vincent Laporte). diff --git a/doc/changelog/04-tactics/11877-master+deprecated-_eqn.rst b/doc/changelog/04-tactics/11877-master+deprecated-_eqn.rst new file mode 100644 index 0000000000..827d484b28 --- /dev/null +++ b/doc/changelog/04-tactics/11877-master+deprecated-_eqn.rst @@ -0,0 +1,5 @@ +- **Removed:** + Deprecated syntax `_eqn` for :tacn:`destruct` and :tacn:`remember`. + Use `eqn:` syntax instead + (`#11877 <https://github.com/coq/coq/pull/11877>`_, + by Hugo Herbelin). diff --git a/doc/changelog/07-commands-and-options/11162-local-cs.rst b/doc/changelog/07-commands-and-options/11162-local-cs.rst index 638222fbe1..b89e047153 100644 --- a/doc/changelog/07-commands-and-options/11162-local-cs.rst +++ b/doc/changelog/07-commands-and-options/11162-local-cs.rst @@ -1,3 +1,3 @@ -- **Added:** Handle the ``#[local]`` attribute in :g:`Canonical +- **Added:** Handle the :attr:`local` attribute in :cmd:`Canonical Structure` declarations (`#11162 <https://github.com/coq/coq/pull/11162>`_, by Enrico Tassi). diff --git a/doc/changelog/07-commands-and-options/11546-rm-uncheck-template.rst b/doc/changelog/07-commands-and-options/11546-rm-uncheck-template.rst new file mode 100644 index 0000000000..d134aeae8b --- /dev/null +++ b/doc/changelog/07-commands-and-options/11546-rm-uncheck-template.rst @@ -0,0 +1,5 @@ +- **Removed:** Deprecated unsound compatibility ``Template Check`` + flag that was introduced in 8.10 to help users gradually move their + template polymorphic inductive type definitions outside sections + (`#11546 <https://github.com/coq/coq/pull/11546>`_, by Pierre-Marie + Pédrot). diff --git a/doc/changelog/07-commands-and-options/11663-remove-polymorphic-unqualified.rst b/doc/changelog/07-commands-and-options/11663-remove-polymorphic-unqualified.rst index 1f8dcd3992..419d683037 100644 --- a/doc/changelog/07-commands-and-options/11663-remove-polymorphic-unqualified.rst +++ b/doc/changelog/07-commands-and-options/11663-remove-polymorphic-unqualified.rst @@ -1,5 +1,6 @@ - **Removed:** Unqualified ``polymorphic``, ``monomorphic``, ``template``, ``notemplate`` attributes (they were deprecated since Coq 8.10). - Use them as sub-attributes of the ``universes`` attribute (`#11663 - <https://github.com/coq/coq/pull/11663>`_, by Théo Zimmermann). + Use :attr:`universes(polymorphic)`, :attr:`universes(monomorphic)`, + :attr:`universes(template)` and :attr:`universes(notemplate)` instead + (`#11663 <https://github.com/coq/coq/pull/11663>`_, by Théo Zimmermann). diff --git a/doc/changelog/07-commands-and-options/11665-cumulative-attr.rst b/doc/changelog/07-commands-and-options/11665-cumulative-attr.rst new file mode 100644 index 0000000000..b6a034941d --- /dev/null +++ b/doc/changelog/07-commands-and-options/11665-cumulative-attr.rst @@ -0,0 +1,12 @@ +- **Added:** + New attributes supported when defining an inductive type + :attr:`universes(cumulative)`, :attr:`universes(noncumulative)` and + :attr:`private(matching)`, which correspond to legacy attributes + ``Cumulative``, ``NonCumulative``, and the so far undocumented + ``Private`` (`#11665 <https://github.com/coq/coq/pull/11665>`_, by + Théo Zimmermann). + +- **Changed:** + Legacy attributes can now be passed in any order. See + :ref:`gallina-attributes` (`#11665 + <https://github.com/coq/coq/pull/11665>`_, by Théo Zimmermann). diff --git a/doc/changelog/07-commands-and-options/11944-rm-searchabout-cmd.rst b/doc/changelog/07-commands-and-options/11944-rm-searchabout-cmd.rst new file mode 100644 index 0000000000..e409c638bb --- /dev/null +++ b/doc/changelog/07-commands-and-options/11944-rm-searchabout-cmd.rst @@ -0,0 +1,3 @@ +- **Removed:** Removed SearchAbout command that was deprecated in 8.5. + Use :cmd:`Search` instead. + (`#11944 <https://github.com/coq/coq/pull/11944>`_, by Jim Fehrle). diff --git a/doc/changelog/08-tools/11851-coqc-flags-fix.rst b/doc/changelog/08-tools/11851-coqc-flags-fix.rst new file mode 100644 index 0000000000..a07e48d2d8 --- /dev/null +++ b/doc/changelog/08-tools/11851-coqc-flags-fix.rst @@ -0,0 +1,6 @@ +- **Changed:** + The order in which the require/load flags `-l`, `-ri`, `-re`, `-rfrom`, etc. + and the option set flags `-set`, `-unset` are processed have been reversed. + In the new behavior, require/load flags are processed before option flags. + (`#11851 <https://github.com/coq/coq/pull/11851>`_, + by Lasse Blaauwbroek). diff --git a/doc/changelog/10-standard-library/11725-cleanup-reals.rst b/doc/changelog/10-standard-library/11725-cleanup-reals.rst new file mode 100644 index 0000000000..02ee7e6c70 --- /dev/null +++ b/doc/changelog/10-standard-library/11725-cleanup-reals.rst @@ -0,0 +1,6 @@ +- **Changed:** + Use implicit arguments for ``ConstructiveReals``. Move ``ConstructiveReals`` + into new directory ``Abstract``. Remove imports of implementations inside + those ``Abstract`` files. Move implementation by means of Cauchy sequences in new directory ``Cauchy``. + (`#11725 <https://github.com/coq/coq/pull/11725>`_, + by Vincent Semeria). diff --git a/doc/changelog/10-standard-library/1185-sort.rst b/doc/changelog/10-standard-library/1185-sort.rst new file mode 100644 index 0000000000..edb5ee3ac4 --- /dev/null +++ b/doc/changelog/10-standard-library/1185-sort.rst @@ -0,0 +1,5 @@ +- **Changed:** + The names of ``Sorted_sort`` and ``LocallySorted_sort`` in ``Coq.Sorting.MergeSort`` + have been swapped to appropriately reflect their meanings + (`#1185 <https://github.com/coq/coq/pull/1185>`_, + by Lysxia). diff --git a/doc/changelog/10-standard-library/11891-fix-order-notations.rst b/doc/changelog/10-standard-library/11891-fix-order-notations.rst new file mode 100644 index 0000000000..d58d26244a --- /dev/null +++ b/doc/changelog/10-standard-library/11891-fix-order-notations.rst @@ -0,0 +1,10 @@ +- **Changed:** + Notations :g:`<=?` and :g:`<?` from ``Coq.Structures.Orders`` and + ``Coq.Sorting.Mergesort.NatOrder`` are now at level 70 rather than + 35, so as to be compatible with the notations defined everywhere + else in the standard library. This may require re-parenthesizing + some expressions. These notations were breaking the ability to + import modules from the standard library that were otherwise + compatible (fixes `#11890 + <https://github.com/coq/coq/issues/11890>`_, `#11891 + <https://github.com/coq/coq/pull/11891>`_, by Jason Gross). diff --git a/doc/changelog/11-infrastructure-and-dependencies/11131-ci+back_to_ocaml_410.rst b/doc/changelog/11-infrastructure-and-dependencies/11131-ci+back_to_ocaml_410.rst new file mode 100644 index 0000000000..778d37e07b --- /dev/null +++ b/doc/changelog/11-infrastructure-and-dependencies/11131-ci+back_to_ocaml_410.rst @@ -0,0 +1,7 @@ +- **Added:** + Bump official OCaml support and CI testing to 4.10.0 + (`#11131 <https://github.com/coq/coq/pull/11131>`_, + `#11123 <https://github.com/coq/coq/pull/11123>`_, + `#11102 <https://github.com/coq/coq/pull/11123>`_, + by Emilio Jesus Gallego Arias, Jacques-Henri Jourdan, + Guillaume Melquiond, and Guillaume Munch-Maccagnoni). @@ -1,5 +1,10 @@ (rule - (targets sphinx_build) + (targets unreleased.rst) + (deps (source_tree changelog)) + (action (with-stdout-to %{targets} (bash "cat changelog/00-title.rst changelog/*/*.rst")))) + +(alias + (name refman-deps) (deps ; We could use finer dependencies here so the build is faster: ; @@ -10,23 +15,34 @@ ; + tools/coqdoc/coqdoc.css (package coq) (source_tree sphinx) - (source_tree tools) + (source_tree tools/coqrst) unreleased.rst - (env_var SPHINXWARNOPT)) - (action - (run env COQLIB=%{project_root} sphinx-build %{env:SPHINXWARNOPT=-W} -b html -d sphinx_build/doctrees sphinx sphinx_build/html))) + (env_var SPHINXWARNOPT))) -(alias - (name refman-html) - (deps sphinx_build)) +(rule + (targets refman-html) + (alias refman-html) + (package coq-doc) + (deps (alias refman-deps)) + (action + (run env COQLIB=%{project_root} sphinx-build %{env:SPHINXWARNOPT=-W} -b html sphinx %{targets}))) (rule - (targets unreleased.rst) - (deps (source_tree changelog)) - (action (with-stdout-to %{targets} (bash "cat changelog/00-title.rst changelog/*/*.rst")))) + (targets refman-pdf) + (alias refman-pdf) + (package coq-doc) + (deps (alias refman-deps)) + (action + (progn + (run env COQLIB=%{project_root} sphinx-build %{env:SPHINXWARNOPT=-W} -b latex sphinx %{targets}) + (chdir %{targets} (run make))))) + +; Installable directories are not yet fully supported by Dune. See +; ocaml/dune#1868. Yet, this makes coq-doc.install a valid target to +; generate the whole Coq documentation. And the result under +; _build/install/default/doc/coq-doc looks just right! -; The install target still needs more work. -; (install -; (section doc) -; (package coq-refman) -; (files sphinx_build)) +(install + (files (refman-html as html/refman) (refman-pdf as pdf/refman)) + (section doc) + (package coq-doc)) diff --git a/doc/plugin_tutorial/tuto1/src/simple_declare.ml b/doc/plugin_tutorial/tuto1/src/simple_declare.ml index 307214089f..8c4dc0e8a6 100644 --- a/doc/plugin_tutorial/tuto1/src/simple_declare.ml +++ b/doc/plugin_tutorial/tuto1/src/simple_declare.ml @@ -1,12 +1,8 @@ -let edeclare ?hook ~name ~poly ~scope ~kind ~opaque sigma udecl body tyopt imps = - let sigma, ce = DeclareDef.prepare_definition ~allow_evars:false - ~opaque ~poly sigma udecl ~types:tyopt ~body in - let uctx = Evd.evar_universe_context sigma in - let ubinders = Evd.universe_binders sigma in - let hook_data = Option.map (fun hook -> hook, uctx, []) hook in - DeclareDef.declare_definition ~name ~scope ~kind ubinders ce imps ?hook_data +let edeclare ?hook ~name ~poly ~scope ~kind ~opaque ~udecl ~impargs sigma body tyopt = + DeclareDef.declare_definition ~name ~scope ~kind ~impargs ?hook + ~opaque ~poly ~udecl ~types:tyopt ~body sigma let declare_definition ~poly name sigma body = let udecl = UState.default_univ_decl in edeclare ~name ~poly ~scope:(DeclareDef.Global Declare.ImportDefaultBehavior) - ~kind:Decls.(IsDefinition Definition) ~opaque:false sigma udecl body None [] + ~kind:Decls.(IsDefinition Definition) ~opaque:false ~impargs:[] ~udecl sigma body None diff --git a/doc/sphinx/addendum/extraction.rst b/doc/sphinx/addendum/extraction.rst index d909f98956..41b726b069 100644 --- a/doc/sphinx/addendum/extraction.rst +++ b/doc/sphinx/addendum/extraction.rst @@ -1,7 +1,7 @@ .. _extraction: -Extraction of programs in |OCaml| and Haskell -============================================= +Program extraction +================== :Authors: Jean-Christophe Filliâtre and Pierre Letouzey diff --git a/doc/sphinx/addendum/miscellaneous-extensions.rst b/doc/sphinx/addendum/miscellaneous-extensions.rst index db8c09d88f..0e8660cb0e 100644 --- a/doc/sphinx/addendum/miscellaneous-extensions.rst +++ b/doc/sphinx/addendum/miscellaneous-extensions.rst @@ -1,10 +1,5 @@ -.. _miscellaneousextensions: - -Miscellaneous extensions -======================== - Program derivation ------------------- +================== |Coq| comes with an extension called ``Derive``, which supports program derivation. Typically in the style of Bird and Meertens or derivations diff --git a/doc/sphinx/addendum/program.rst b/doc/sphinx/addendum/program.rst index 549249d25c..5cffe9e435 100644 --- a/doc/sphinx/addendum/program.rst +++ b/doc/sphinx/addendum/program.rst @@ -98,10 +98,17 @@ coercions. .. flag:: Program Mode Enables the program mode, in which 1) typechecking allows subset coercions and - 2) the elaboration of pattern matching of :cmd:`Program Fixpoint` and - :cmd:`Program Definition` act - like Program Fixpoint/Definition, generating obligations if there are - unresolved holes after typechecking. + 2) the elaboration of pattern matching of :cmd:`Fixpoint` and + :cmd:`Definition` act as if the :attr:`program` attribute had been + used, generating obligations if there are unresolved holes after + typechecking. + +.. attr:: program + + This attribute allows to use the Program mode on a specific + definition. An alternative syntax is to use the legacy ``Program`` + prefix (cf. :n:`@legacy_attr`) as documented in the rest of this + chapter. .. _syntactic_control: @@ -155,7 +162,7 @@ Program Definition This command types the value term in Russell and generates proof obligations. Once solved using the commands shown below, it binds the - final |Coq| term to the name ``ident`` in the environment. + final |Coq| term to the name :n:`@ident` in the environment. .. exn:: @ident already exists. :name: @ident already exists. (Program Definition) @@ -163,12 +170,12 @@ Program Definition .. cmdv:: Program Definition @ident : @type := @term - It interprets the type ``type``, potentially generating proof + It interprets the type :n:`@type`, potentially generating proof obligations to be resolved. Once done with them, we have a |Coq| - type |type_0|. It then elaborates the preterm ``term`` into a |Coq| - term |term_0|, checking that the type of |term_0| is coercible to - |type_0|, and registers ``ident`` as being of type |type_0| once the - set of obligations generated during the interpretation of |term_0| + type :n:`@type__0`. It then elaborates the preterm :n:`@term` into a |Coq| + term :n:`@term__0`, checking that the type of :n:`@term__0` is coercible to + :n:`@type__0`, and registers :n:`@ident` as being of type :n:`@type__0` once the + set of obligations generated during the interpretation of :n:`@term__0` and the aforementioned coercion derivation are solved. .. exn:: In environment … the term: @term does not have type @type. Actually, it has type ... @@ -178,7 +185,7 @@ Program Definition This is equivalent to: - :g:`Program Definition ident : forall binders, type := fun binders => term`. + :n:`Program Definition @ident : forall {* @binder }, @type := fun {* @binder } => @term`. .. TODO refer to production in alias diff --git a/doc/sphinx/addendum/ring.rst b/doc/sphinx/addendum/ring.rst index 76174e32b5..2a321b5cbf 100644 --- a/doc/sphinx/addendum/ring.rst +++ b/doc/sphinx/addendum/ring.rst @@ -1,8 +1,12 @@ +.. |bdi| replace:: :math:`\beta\delta\iota` .. |ra| replace:: :math:`\rightarrow_{\beta\delta\iota}` .. |la| replace:: :math:`\leftarrow_{\beta\delta\iota}` .. |eq| replace:: `=`:sub:`(by the main correctness theorem)` .. |re| replace:: ``(PEeval`` `v` `ap`\ ``)`` .. |le| replace:: ``(Pphi_dev`` `v` ``(norm`` `ap`\ ``))`` +.. |N| replace:: ``N`` +.. |nat| replace:: ``nat`` +.. |Z| replace:: ``Z`` .. _theringandfieldtacticfamilies: diff --git a/doc/sphinx/addendum/type-classes.rst b/doc/sphinx/addendum/type-classes.rst index 7abeca7815..bd4c276571 100644 --- a/doc/sphinx/addendum/type-classes.rst +++ b/doc/sphinx/addendum/type-classes.rst @@ -47,7 +47,7 @@ Leibniz equality on some type. An example implementation is: | tt, tt => eq_refl tt end }. -Using the attribute ``refine``, if the term is not sufficient to +Using the :attr:`refine` attribute, if the term is not sufficient to finish the definition (e.g. due to a missing field or non-inferable hole) it must be finished in proof mode. If it is sufficient a trivial proof mode with no open goals is started. @@ -77,9 +77,9 @@ remaining fields, e.g.: Defined. One has to take care that the transparency of every field is -determined by the transparency of the :cmd:`Instance` proof. One can use -alternatively the :cmd:`Program Instance` variant which has richer facilities -for dealing with obligations. +determined by the transparency of the :cmd:`Instance` proof. One can +use alternatively the :attr:`program` attribute to get richer +facilities for dealing with obligations. Binding classes @@ -174,7 +174,7 @@ For example: .. coqtop:: in - Global Program Instance option_eqb : EqDec (option A) := + #[ global, program ] Instance option_eqb : EqDec (option A) := { eqb x y := match x, y with | Some x, Some y => eqb x y | None, None => true @@ -188,7 +188,7 @@ For example: About option_eqb. -Here the :cmd:`Global` modifier redeclares the instance at the end of the +Here the :attr:`global` attribute redeclares the instance at the end of the section, once it has been generalized by the context variables it uses. @@ -300,9 +300,11 @@ Summary of the commands The :cmd:`Class` command is used to declare a typeclass with parameters :token:`binders` and fields the declared record fields. - This command supports the :attr:`universes(polymorphic)`, :attr:`universes(monomorphic)`, + Like any command declaring a record, this command supports the + :attr:`universes(polymorphic)`, :attr:`universes(monomorphic)`, :attr:`universes(template)`, :attr:`universes(notemplate)`, - :attr:`Cumulative`, :attr:`NonCumulative` and :attr:`Private` attributes. + :attr:`universes(cumulative)`, :attr:`universes(noncumulative)` and + :attr:`private(matching)` attributes. .. _singleton-class: @@ -341,6 +343,25 @@ Summary of the commands :tacn:`auto` hints. If the priority :token:`num` is not specified, it defaults to the number of non-dependent binders of the instance. + This command supports the :attr:`global` attribute that can be + used on instances declared in a section so that their + generalization is automatically redeclared after the section is + closed. + + Like :cmd:`Definition`, it also supports the :attr:`program` + attribute to switch the type checking to `Program` (chapter + :ref:`programs`) and use the obligation mechanism to manage missing + fields. + + Finally, it supports the lighter :attr:`refine` attribute: + + .. attr:: refine + + This attribute can be used to leave holes or not provide all + fields in the definition of an instance and open the tactic mode + to fill them. It works exactly as if no body had been given and + the :tacn:`refine` tactic has been used first. + .. cmdv:: Instance @ident {* @binder } : forall {* @binder }, @term__0 {+ @term} {? | @num } := @term This syntax is used for declaration of singleton class instances or @@ -348,19 +369,6 @@ Summary of the commands {+ @term}`. One need not even mention the unique field name for singleton classes. - .. cmdv:: Global Instance - :name: Global Instance - - One can use the :cmd:`Global` modifier on instances declared in a - section so that their generalization is automatically redeclared - after the section is closed. - - .. cmdv:: Program Instance - :name: Program Instance - - Switches the type checking to `Program` (chapter :ref:`programs`) and - uses the obligation mechanism to manage missing fields. - .. cmdv:: Declare Instance :name: Declare Instance diff --git a/doc/sphinx/addendum/universe-polymorphism.rst b/doc/sphinx/addendum/universe-polymorphism.rst index 0e326f45d2..a08495badd 100644 --- a/doc/sphinx/addendum/universe-polymorphism.rst +++ b/doc/sphinx/addendum/universe-polymorphism.rst @@ -122,62 +122,92 @@ in a universe strictly higher than :g:`Set`. Polymorphic, Monomorphic ------------------------- -.. cmd:: Polymorphic @definition +.. attr:: universes(polymorphic) - As shown in the examples, polymorphic definitions and inductives can be - declared using the ``Polymorphic`` prefix. + This attribute can be used to declare universe polymorphic + definitions and inductive types. There is also a legacy syntax + using the ``Polymorphic`` prefix (see :n:`@legacy_attr`) which, as + shown in the examples, is more commonly used. .. flag:: Universe Polymorphism - Once enabled, this flag will implicitly prepend ``Polymorphic`` to any - definition of the user. + This flag is off by default. When it is on, new declarations are + polymorphic unless the :attr:`universes(monomorphic)` attribute is + used. -.. cmd:: Monomorphic @definition +.. attr:: universes(monomorphic) - When the :flag:`Universe Polymorphism` flag is set, to make a definition - producing global universe constraints, one can use the ``Monomorphic`` prefix. + This attribute can be used to declare universe monomorphic + definitions and inductive types (i.e. global universe constraints + are produced), even when the :flag:`Universe Polymorphism` flag is + on. There is also a legacy syntax using the ``Monomorphic`` prefix + (see :n:`@legacy_attr`). -Many other commands support the ``Polymorphic`` flag, including: +Many other commands can be used to declare universe polymorphic or +monomorphic constants depending on whether the :flag:`Universe +Polymorphism` flag is on or the :attr:`universes(polymorphic)` or +:attr:`universes(monomorphic)` attributes are used: -.. TODO add links on each of these? +- :cmd:`Lemma`, :cmd:`Axiom`, etc. can be used to declare universe + polymorphic constants. -- ``Lemma``, ``Axiom``, and all the other “definition” keywords support - polymorphism. +- Using the :attr:`universes(polymorphic)` attribute with the + :cmd:`Section` command will locally set the polymorphism flag inside + the section. -- :cmd:`Section` will locally set the polymorphism flag inside the section. +- :cmd:`Variable`, :cmd:`Context`, :cmd:`Universe` and + :cmd:`Constraint` in a section support polymorphism. See + :ref:`universe-polymorphism-in-sections` for more details. -- ``Variables``, ``Context``, ``Universe`` and ``Constraint`` in a section support - polymorphism. See :ref:`universe-polymorphism-in-sections` for more details. - -- :cmd:`Hint Resolve` and :cmd:`Hint Rewrite` will use the auto/rewrite hint - polymorphically, not at a single instance. +- Using the :attr:`universes(polymorphic)` attribute with the + :cmd:`Hint Resolve` or :cmd:`Hint Rewrite` commands will make + :tacn:`auto` / :tacn:`rewrite` use the hint polymorphically, not at + a single instance. .. _cumulative: Cumulative, NonCumulative ------------------------- -Polymorphic inductive types, coinductive types, variants and records can be -declared cumulative using the :g:`Cumulative` prefix. +.. attr:: universes(cumulative) + + Polymorphic inductive types, coinductive types, variants and + records can be declared cumulative using this attribute or the + legacy ``Cumulative`` prefix (see :n:`@legacy_attr`) which, as + shown in the examples, is more commonly used. -.. cmd:: Cumulative @inductive + This means that two instances of the same inductive type (family) + are convertible based on the universe variances; they do not need + to be equal. - Declares the inductive as cumulative + .. exn:: The cumulative and noncumulative attributes can only be used in a polymorphic context. -Alternatively, there is a :flag:`Polymorphic Inductive -Cumulativity` flag which when set, makes all subsequent *polymorphic* -inductive definitions cumulative. When set, inductive types and the -like can be enforced to be non-cumulative using the :g:`NonCumulative` -prefix. + Using this attribute requires being in a polymorphic context, + i.e. either having the :flag:`Universe Polymorphism` flag on, or + having used the :attr:`universes(polymorphic)` attribute as + well. -.. cmd:: NonCumulative @inductive + .. note:: - Declares the inductive as non-cumulative + ``#[ universes(polymorphic), universes(cumulative) ]`` can be + abbreviated into ``#[ universes(polymorphic, cumulative) ]``. .. flag:: Polymorphic Inductive Cumulativity - When this flag is on, it sets all following polymorphic inductive - types as cumulative (it is off by default). + When this flag is on (it is off by default), it makes all + subsequent *polymorphic* inductive definitions cumulative, unless + the :attr:`universes(noncumulative)` attribute is used. It has no + effect on *monomorphic* inductive definitions. + +.. attr:: universes(noncumulative) + + Declares the inductive type as non-cumulative even if the + :flag:`Polymorphic Inductive Cumulativity` flag is on. There is + also a legacy syntax using the ``NonCumulative`` prefix (see + :n:`@legacy_attr`). + + This means that two instances of the same inductive type (family) + are convertible only if all the universes are equal. Consider the examples below. @@ -220,34 +250,10 @@ The following is an example of a record with non-trivial subtyping relation: E[Γ] ⊢ \mathsf{packType}@\{i\} =_{βδιζη} \mathsf{packType}@\{j\}~\mbox{ whenever }~i ≤ j -Cumulative inductive types, coinductive types, variants and records -only make sense when they are universe polymorphic. Therefore, an -error is issued whenever the user uses the :g:`Cumulative` or -:g:`NonCumulative` prefix in a monomorphic context. -Notice that this is not the case for the :flag:`Polymorphic Inductive Cumulativity` flag. -That is, this flag, when set, makes all subsequent *polymorphic* -inductive declarations cumulative (unless, of course the :g:`NonCumulative` prefix is used) -but has no effect on *monomorphic* inductive declarations. - -Consider the following examples. - -.. coqtop:: all reset - - Fail Monomorphic Cumulative Inductive Unit := unit. - -.. coqtop:: all reset - - Fail Monomorphic NonCumulative Inductive Unit := unit. - -.. coqtop:: all reset - - Set Polymorphic Inductive Cumulativity. - Inductive Unit := unit. - An example of a proof using cumulativity ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -.. coqtop:: in +.. coqtop:: in reset Set Universe Polymorphism. Set Polymorphic Inductive Cumulativity. @@ -368,10 +374,14 @@ to universes and explicitly instantiate polymorphic definitions. In the monorphic case, this command declares a new global universe named :g:`ident`, which can be referred to using its qualified name as well. Global universe names live in a separate namespace. The - command supports the ``Polymorphic`` flag only in sections, meaning the - universe quantification will be discharged on each section definition + command supports the :attr:`universes(polymorphic)` attribute (or + the ``Polymorphic`` prefix) only in sections, meaning the universe + quantification will be discharged on each section definition independently. + .. exn:: Polymorphic universes can only be declared inside sections, use Monomorphic Universe instead. + :undocumented: + .. cmd:: Constraint @univ_constraint Polymorphic Constraint @univ_constraint @@ -379,9 +389,10 @@ to universes and explicitly instantiate polymorphic definitions. If consistent, the constraint is then enforced in the global environment. Like :cmd:`Universe`, it can be used with the - ``Polymorphic`` prefix in sections only to declare constraints - discharged at section closing time. One cannot declare a global - constraint on polymorphic universes. + :attr:`universes(polymorphic)` attribute (or the ``Polymorphic`` + prefix) in sections only to declare constraints discharged at + section closing time. One cannot declare a global constraint on + polymorphic universes. .. exn:: Undeclared universe @ident. :undocumented: @@ -389,6 +400,9 @@ to universes and explicitly instantiate polymorphic definitions. .. exn:: Universe inconsistency. :undocumented: + .. exn:: Polymorphic universe constraints can only be declared inside sections, use Monomorphic Constraint instead + :undocumented: + Polymorphic definitions ~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/doc/sphinx/appendix/history-and-changes/index.rst b/doc/sphinx/appendix/history-and-changes/index.rst new file mode 100644 index 0000000000..50ffec8e3f --- /dev/null +++ b/doc/sphinx/appendix/history-and-changes/index.rst @@ -0,0 +1,21 @@ +.. _history-and-changes: + +========================== +History and recent changes +========================== + +This chapter is divided in two parts. The first one is about the +:ref:`early history of Coq <history>` and is presented in +chronological order. The second one provides :ref:`release notes +about recent versions of Coq <changes>` and is presented in reverse +chronological order. When updating your copy of Coq to a new version +(especially a new major version), it is strongly recommended that you +read the corresponding release notes. They may contain advice that +will help you understand the differences with the previous version and +upgrade your projects. + +.. toctree:: + :maxdepth: 1 + + ../../history + ../../changes diff --git a/doc/sphinx/appendix/indexes/index.rst b/doc/sphinx/appendix/indexes/index.rst new file mode 100644 index 0000000000..a5032ff822 --- /dev/null +++ b/doc/sphinx/appendix/indexes/index.rst @@ -0,0 +1,24 @@ +:orphan: + +.. _indexes: + +======== +Indexes +======== + +We provide various specialized indexes that are helpful to quickly +find what you are looking for. + +.. toctree:: + + ../../genindex + ../../coq-cmdindex + ../../coq-tacindex + ../../coq-optindex + ../../coq-exnindex + +For reference, here are direct links to the documentation of: + +- :ref:`flags, options and tables <flags-options-tables>`; +- controlling the display of warning messages with the :opt:`Warnings` + option. diff --git a/doc/sphinx/changes.rst b/doc/sphinx/changes.rst index 6d9979a704..7401aff48c 100644 --- a/doc/sphinx/changes.rst +++ b/doc/sphinx/changes.rst @@ -1,8 +1,10 @@ +.. _changes: + -------------- Recent changes -------------- -.. ifconfig:: not coq_config.is_a_released_version +.. ifconfig:: not is_a_released_version .. include:: ../unreleased.rst @@ -158,7 +160,7 @@ Changes in 8.11+beta1 Annotation in `Arguments` for bidirectionality hints: it is now possible to tell type inference to use type information from the context once the `n` first arguments of an application are known. The syntax is: - `Arguments foo x y & z`. See :cmd:`Arguments (bidirectionality hints)` + `Arguments foo x y & z`. See :ref:`bidirectionality_hints` (`#10049 <https://github.com/coq/coq/pull/10049>`_, by Maxime Dénès with help from Enrico Tassi). - **Added:** @@ -214,13 +216,13 @@ Changes in 8.11+beta1 - **Changed:** Output of the :cmd:`Print` and :cmd:`About` commands. Arguments meta-data is now displayed as the corresponding - :cmd:`Arguments <Arguments (implicits)>` command instead of the + :cmd:`Arguments` command instead of the human-targeted prose used in previous Coq versions. (`#10985 <https://github.com/coq/coq/pull/10985>`_, by Gaëtan Gilbert). .. _811RefineInstance: -- **Added:** ``#[refine]`` attribute for :cmd:`Instance`, a more +- **Added:** :attr:`refine` attribute for :cmd:`Instance`, a more predictable version of the old ``Refine Instance Mode`` which unconditionally opens a proof (`#10996 <https://github.com/coq/coq/pull/10996>`_, by Gaëtan Gilbert). @@ -381,6 +383,10 @@ Changes in 8.11+beta1 <https://github.com/coq/coq/issues/3890>`_ and `#4638 <https://github.com/coq/coq/issues/4638>`_ by Maxime Dénès, review by Gaëtan Gilbert). +- **Changed:** + :cmd:`Fail` does not catch critical errors (including "stack overflow") + anymore (`#10173 <https://github.com/coq/coq/pull/10173>`_, + by Gaëtan Gilbert). - **Removed:** Undocumented :n:`Instance : !@type` syntax (`#10185 <https://github.com/coq/coq/pull/10185>`_, by Gaëtan Gilbert). @@ -683,7 +689,7 @@ reference manual. Here are the most important user-visible changes: - Universes: - - Added :cmd:`Print Universes Subgraph` variant of :cmd:`Print Universes`. + - Added Subgraph variant to :cmd:`Print Universes`. Try for instance :g:`Print Universes Subgraph(sigT2.u1 sigT_of_sigT2.u1 projT3_eq.u1).` (`#8451 <https://github.com/coq/coq/pull/8451>`_, by Gaëtan Gilbert). @@ -1314,7 +1320,7 @@ Changes in 8.10+beta3 rules governing template-polymorphic types. To help users incrementally fix this issue, a command line option - `-no-template-check` and a global flag :flag:`Template Check` are + `-no-template-check` and a global flag ``Template Check`` are available to selectively disable the new check. Use at your own risk. (`#9918 <https://github.com/coq/coq/pull/9918>`_, by Matthieu Sozeau @@ -1506,7 +1512,7 @@ changes: - Removed deprecated commands ``Arguments Scope`` and ``Implicit Arguments`` in favor of :cmd:`Arguments (scopes)` and - :cmd:`Arguments (implicits)`, with the help of Jasper Hugunin. + :cmd:`Arguments`, with the help of Jasper Hugunin. - New flag :flag:`Uniform Inductive Parameters` by Jasper Hugunin to avoid repeating uniform parameters in constructor declarations. @@ -4713,7 +4719,7 @@ Specification language Module system -- Include Type is now deprecated since Include now accept both modules and +- Include Type is now deprecated since Include now accepts both modules and module types. - Declare ML Module supports Local option. - The sharing between non-logical object and the management of the diff --git a/doc/sphinx/conf.py b/doc/sphinx/conf.py index 98272810f6..2ed9ec21b3 100755 --- a/doc/sphinx/conf.py +++ b/doc/sphinx/conf.py @@ -46,7 +46,7 @@ with open("refman-preamble.rst") as s: # -- General configuration ------------------------------------------------ # If your documentation needs a minimal Sphinx version, state it here. -needs_sphinx = '1.7.8' +needs_sphinx = '1.8.0' # Add any Sphinx extension module names here, as strings. They can be # extensions coming with Sphinx (named 'sphinx.ext.*') or your custom @@ -100,7 +100,7 @@ def copy_formatspecific_files(app): def setup(app): app.connect('builder-inited', copy_formatspecific_files) - app.add_config_value('coq_config', coq_config, 'env') + app.add_config_value('is_a_released_version', coq_config.is_a_released_version, 'env') # The master toctree document. # We create this file in `copy_master_doc` above. @@ -186,9 +186,7 @@ nitpick_ignore = [ ('token', token) for token in [ 'assums', 'binders', 'collection', - 'definition', 'dirpath', - 'inductive', 'ind_body', 'modpath', 'module', diff --git a/doc/sphinx/genindex.rst b/doc/sphinx/genindex.rst index 29f792b3aa..e3a27fd7c4 100644 --- a/doc/sphinx/genindex.rst +++ b/doc/sphinx/genindex.rst @@ -2,6 +2,6 @@ .. hack to get index in TOC ------ -Index ------ +------------- +General index +------------- diff --git a/doc/sphinx/history.rst b/doc/sphinx/history.rst index c4a48d6985..153dc1f368 100644 --- a/doc/sphinx/history.rst +++ b/doc/sphinx/history.rst @@ -1,3 +1,5 @@ +.. _history: + -------------------- Early history of Coq -------------------- diff --git a/doc/sphinx/index.html.rst b/doc/sphinx/index.html.rst index 0a20d1c47b..6069ed42fe 100644 --- a/doc/sphinx/index.html.rst +++ b/doc/sphinx/index.html.rst @@ -8,84 +8,37 @@ Contents -------- .. toctree:: - :caption: Indexes - - genindex - coq-cmdindex - coq-tacindex - coq-optindex - coq-exnindex - -.. No entries yet - * :index:`thmindex` - -.. toctree:: - :caption: Preamble self - history - changes .. toctree:: - :caption: The language + :caption: Specification language - language/gallina-specification-language - language/gallina-extensions - language/coq-library - language/cic - language/module-system + language/core/index + language/extensions/index .. toctree:: - :caption: The proof engine + :caption: Proofs - proof-engine/vernacular-commands - proof-engine/proof-handling - proof-engine/tactics - proof-engine/ltac - proof-engine/ltac2 - proof-engine/detailed-tactic-examples - proof-engine/ssreflect-proof-language + proofs/writing-proofs/index + proofs/automatic-tactics/index + proofs/creating-tactics/index .. toctree:: - :caption: User extensions + :caption: Using Coq - user-extensions/syntax-extensions - user-extensions/proof-schemes + using/libraries/index + using/tools/index .. toctree:: - :caption: Practical tools + :caption: Appendix - practical-tools/coq-commands - practical-tools/utilities - practical-tools/coqide - -.. toctree:: - :caption: Addendum - - addendum/extended-pattern-matching - addendum/implicit-coercions - addendum/canonical-structures - addendum/type-classes - addendum/omega - addendum/micromega - addendum/extraction - addendum/program - addendum/ring - addendum/nsatz - addendum/generalized-rewriting - addendum/parallel-proof-processing - addendum/miscellaneous-extensions - addendum/universe-polymorphism - addendum/sprop + appendix/history-and-changes/index + appendix/indexes/index + zebibliography -.. toctree:: - :caption: Reference +.. No entries yet + * :index:`thmindex` - zebibliography .. include:: license.rst - -.. [#PG] Proof-General is available at https://proofgeneral.github.io/. - Optionally, you can enhance it with the minor mode - Company-Coq :cite:`Pit16` - (see https://github.com/cpitclaudel/company-coq). diff --git a/doc/sphinx/index.latex.rst b/doc/sphinx/index.latex.rst index 5562736997..62d9525194 100644 --- a/doc/sphinx/index.latex.rst +++ b/doc/sphinx/index.latex.rst @@ -10,81 +10,39 @@ Introduction .. include:: license.rst -.. [#PG] Proof-General is available at https://proofgeneral.github.io/. - Optionally, you can enhance it with the minor mode - Company-Coq :cite:`Pit16` - (see https://github.com/cpitclaudel/company-coq). - -.. include:: history.rst - -.. include:: changes.rst - ------------- -The language ------------- +---------------------- +Specification language +---------------------- .. toctree:: - language/gallina-specification-language - language/gallina-extensions - language/coq-library - language/cic - language/module-system + language/core/index + language/extensions/index ----------------- -The proof engine ----------------- +------ +Proofs +------ .. toctree:: - proof-engine/vernacular-commands - proof-engine/proof-handling - proof-engine/tactics - proof-engine/ltac - proof-engine/ltac2 - proof-engine/detailed-tactic-examples - proof-engine/ssreflect-proof-language + proofs/writing-proofs/index + proofs/automatic-tactics/index + proofs/creating-tactics/index ---------------- -User extensions ---------------- +--------- +Using Coq +--------- .. toctree:: - user-extensions/syntax-extensions - user-extensions/proof-schemes - ---------------- -Practical tools ---------------- - -.. toctree:: - - practical-tools/coq-commands - practical-tools/utilities - practical-tools/coqide + using/libraries/index + using/tools/index -------- -Addendum +Appendix -------- .. toctree:: - addendum/extended-pattern-matching - addendum/implicit-coercions - addendum/canonical-structures - addendum/type-classes - addendum/omega - addendum/micromega - addendum/extraction - addendum/program - addendum/ring - addendum/nsatz - addendum/generalized-rewriting - addendum/parallel-proof-processing - addendum/miscellaneous-extensions - addendum/universe-polymorphism - addendum/sprop - -.. toctree:: + appendix/history-and-changes/index zebibliography diff --git a/doc/sphinx/introduction.rst b/doc/sphinx/introduction.rst index 1424b4f3e1..b059fb4069 100644 --- a/doc/sphinx/introduction.rst +++ b/doc/sphinx/introduction.rst @@ -1,107 +1,68 @@ -This document is the Reference Manual of the |Coq| proof assistant. -To start using Coq, it is advised to first read a tutorial. -Links to several tutorials can be found at -https://coq.inria.fr/documentation and -https://github.com/coq/coq/wiki#coq-tutorials - -The |Coq| system is designed to develop mathematical proofs, and -especially to write formal specifications, programs and to verify that -programs are correct with respect to their specifications. It provides a -specification language named |Gallina|. Terms of |Gallina| can represent -programs as well as properties of these programs and proofs of these -properties. Using the so-called *Curry-Howard isomorphism*, programs, -properties and proofs are formalized in the same language called -*Calculus of Inductive Constructions*, that is a -:math:`\lambda`-calculus with a rich type system. All logical judgments -in |Coq| are typing judgments. The very heart of the |Coq| system is the -type checking algorithm that checks the correctness of proofs, in other -words that checks that a program complies to its specification. |Coq| also -provides an interactive proof assistant to build proofs using specific -programs called *tactics*. - -All services of the |Coq| proof assistant are accessible by interpretation -of a command language called *the vernacular*. - -Coq has an interactive mode in which commands are interpreted as the -user types them in from the keyboard and a compiled mode where commands -are processed from a file. - -- In interactive mode, users can develop their theories and proofs step by - step, and query the system for available theorems and definitions. The - interactive mode is generally run with the help of an IDE, such - as CoqIDE, documented in :ref:`coqintegrateddevelopmentenvironment`, - Emacs with Proof-General :cite:`Asp00` [#PG]_, - or jsCoq to run Coq in your browser (see https://github.com/ejgallego/jscoq). - The `coqtop` read-eval-print-loop can also be used directly, for debugging - purposes. - -- The compiled mode acts as a proof checker taking a file containing a - whole development in order to ensure its correctness. Moreover, - |Coq|’s compiler provides an output file containing a compact - representation of its input. The compiled mode is run with the `coqc` - command. - -.. seealso:: :ref:`thecoqcommands`. - -How to read this book ---------------------- - -This is a Reference Manual, so it is not intended for continuous reading. -We recommend using the various indexes to quickly locate the documentation -you are looking for. There is a global index, and a number of specific indexes -for tactics, vernacular commands, and error messages and warnings. -Nonetheless, the manual has some structure that is explained below. - -- The first part describes the specification language, |Gallina|. - Chapters :ref:`gallinaspecificationlanguage` and :ref:`extensionsofgallina` describe the concrete - syntax as well as the meaning of programs, theorems and proofs in the - Calculus of Inductive Constructions. Chapter :ref:`thecoqlibrary` describes the - standard library of |Coq|. Chapter :ref:`calculusofinductiveconstructions` is a mathematical description - of the formalism. Chapter :ref:`themodulesystem` describes the module - system. - -- The second part describes the proof engine. It is divided into several - chapters. Chapter :ref:`vernacularcommands` presents all commands (we - call them *vernacular commands*) that are not directly related to - interactive proving: requests to the environment, complete or partial - evaluation, loading and compiling files. How to start and stop - proofs, do multiple proofs in parallel is explained in - Chapter :ref:`proofhandling`. In Chapter :ref:`tactics`, all commands that - realize one or more steps of the proof are presented: we call them - *tactics*. The legacy language to combine these tactics into complex proof - strategies is given in Chapter :ref:`ltac`. The currently experimental - language that will eventually replace Ltac is presented in - Chapter :ref:`ltac2`. Examples of tactics - are described in Chapter :ref:`detailedexamplesoftactics`. - Finally, the |SSR| proof language is presented in - Chapter :ref:`thessreflectprooflanguage`. - -- The third part describes how to extend the syntax of |Coq| in - Chapter :ref:`syntaxextensionsandinterpretationscopes` and how to define - new induction principles in Chapter :ref:`proofschemes`. - -- In the fourth part more practical tools are documented. First in - Chapter :ref:`thecoqcommands`, the usage of `coqc` (batch mode) and - `coqtop` (interactive mode) with their options is described. Then, - in Chapter :ref:`utilities`, various utilities that come with the - |Coq| distribution are presented. Finally, Chapter :ref:`coqintegrateddevelopmentenvironment` - describes CoqIDE. - -- The fifth part documents a number of advanced features, including coercions, - canonical structures, typeclasses, program extraction, and specialized - solvers and tactics. See the table of contents for a complete list. - -List of additional documentation --------------------------------- - -This manual does not contain all the documentation the user may need -about |Coq|. Various informations can be found in the following documents: - -Installation - A text file `INSTALL` that comes with the sources explains how to - install |Coq|. - -The |Coq| standard library - A commented version of sources of the |Coq| standard library - (including only the specifications, the proofs are removed) is - available at https://coq.inria.fr/stdlib/. +This is the reference manual of |Coq|. Coq is an interactive theorem +prover. It lets you formalize mathematical concepts and then helps +you interactively generate machine-checked proofs of theorems. +Machine checking gives users much more confidence that the proofs are +correct compared to human-generated and -checked proofs. Coq has been +used in a number of flagship verification projects, including the +`CompCert verified C compiler <http://compcert.inria.fr/>`_, and has +served to verify the proof of the `four color theorem +<https://github.com/math-comp/fourcolor>`_ (among many other +mathematical formalizations). + +Users generate proofs by entering a series of tactics that constitute +steps in the proof. There are many built-in tactics, some of which +are elementary, while others implement complex decision procedures +(such as :tacn:`lia`, a decision procedure for linear integer +arithmetic). :ref:`Ltac <ltac>` and its planned replacement, +:ref:`Ltac2 <ltac2>`, provide languages to define new tactics by +combining existing tactics with looping and conditional constructs. +These permit automation of large parts of proofs and sometimes entire +proofs. Furthermore, users can add novel tactics or functionality by +creating Coq plugins using OCaml. + +The Coq kernel, a small part of Coq, does the final verification that +the tactic-generated proof is valid. Usually the tactic-generated +proof is indeed correct, but delegating proof verification to the +kernel means that even if a tactic is buggy, it won't be able to +introduce an incorrect proof into the system. + +Finally, Coq also supports extraction of verified programs to +programming languages such as OCaml and Haskell. This provides a way +of executing Coq code efficiently and can be used to create verified +software libraries. + +To learn Coq, beginners are advised to first start with a tutorial / +book. Several such tutorials / books are listed at +https://coq.inria.fr/documentation. + +This manual is organized in three main parts, plus an appendix: + +- **The first part presents the specification language of Coq**, that + allows to define programs and state mathematical theorems. + :ref:`core-language` presents the language that the kernel of Coq + understands. :ref:`extensions` presents the richer language, with + notations, implicits, etc. that a user can use and which is + translated down to the language of the kernel by means of an + "elaboration process". + +- **The second part presents the interactive proof mode**, the central + feature of Coq. :ref:`writing-proofs` introduces this interactive + proof mode and the available proof languages. + :ref:`automatic-tactics` presents some more advanced tactics, while + :ref:`writing-tactics` is about the languages that allow a user to + combine tactics together and develop new ones. + +- **The third part shows how to use Coq in practice.** + :ref:`libraries` presents some of the essential reusable blocks from + the ecosystem and some particularly important extensions such as the + program extraction mechanism. :ref:`tools` documents important + tools that a user needs to build a Coq project. + +- In the appendix, :ref:`history-and-changes` presents the history of + Coq and changes in recent releases. This is an important reference + if you upgrade the version of Coq that you use. The various + :ref:`indexes <indexes>` are very useful to **quickly browse the + manual and find what you are looking for.** They are often the main + entry point to the manual. + +The full table of contents is presented below: diff --git a/doc/sphinx/language/cic.rst b/doc/sphinx/language/cic.rst index 4beaff70f5..09a3897a06 100644 --- a/doc/sphinx/language/cic.rst +++ b/doc/sphinx/language/cic.rst @@ -47,8 +47,7 @@ provable. An object of type :math:`\Prop` is called a proposition. The sort :math:`\SProp` is like :math:`\Prop` but the propositions in :math:`\SProp` are known to have irrelevant proofs (all proofs are equal). Objects of type :math:`\SProp` are called strict propositions. -:math:`\SProp` is rejected except when using the compiler option -``-allow-sprop``. See :ref:`sprop` for information about using +See :ref:`sprop` for information about using :math:`\SProp`, and :cite:`Gilbert:POPL2019` for meta theoretical considerations. @@ -1200,45 +1199,47 @@ Conversion is preserved as any (partial) instance :math:`I_j~q_1 … q_r` or at level :math:`\Type` (without annotations or hiding it behind a definition) template polymorphic if possible. - This can be prevented using the ``universes(notemplate)`` + This can be prevented using the :attr:`universes(notemplate)` attribute. + Template polymorphism and full universe polymorphism (see Chapter + :ref:`polymorphicuniverses`) are incompatible, so if the latter is + enabled (through the :flag:`Universe Polymorphism` flag or the + :attr:`universes(polymorphic)` attribute) it will prevail over + automatic template polymorphism. + .. warn:: Automatically declaring @ident as template polymorphic. - Warning ``auto-template`` can be used to find which types are - implicitly declared template polymorphic by :flag:`Auto Template - Polymorphism`. + Warning ``auto-template`` can be used (it is off by default) to + find which types are implicitly declared template polymorphic by + :flag:`Auto Template Polymorphism`. An inductive type can be forced to be template polymorphic using - the ``universes(template)`` attribute: it should then fulfill the - criterion to be template polymorphic or an error is raised. - -.. exn:: Inductive @ident cannot be made template polymorphic. - - This error is raised when the `#[universes(template)]` attribute is - on but the inductive cannot be made polymorphic on any universe or be - inferred to live in :math:`\Prop` or :math:`\Set`. - - Template polymorphism and universe polymorphism (see Chapter - :ref:`polymorphicuniverses`) are incompatible, so if the later is - enabled it will prevail over automatic template polymorphism and - cause an error when using the ``universes(template)`` attribute. - -.. flag:: Template Check - - This flag is on by default. Turning it off disables the check of - locality of the sorts when abstracting the inductive over its - parameters. This is a deprecated and *unsafe* flag that can introduce - inconsistencies, it is only meant to help users incrementally update - code from Coq versions < 8.10 which did not implement this check. - The `Coq89.v` compatibility file sets this flag globally. A global - ``-no-template-check`` command line option is also available. Use at - your own risk. Use of this flag is recorded in the typing flags - associated to a definition but is *not* supported by the |Coq| - checker (`coqchk`). It will appear in :g:`Print Assumptions` and - :g:`About @ident` output involving inductive declarations that were - (potentially unsoundly) assumed to be template polymorphic. + the :attr:`universes(template)` attribute: in this case, the + warning is not emitted. + +.. attr:: universes(template) + + This attribute can be used to explicitly declare an inductive type + as template polymorphic, whether the :flag:`Auto Template + Polymorphism` flag is on or off. + + .. exn:: template and polymorphism not compatible + + This attribute cannot be used in a full universe polymorphic + context, i.e. if the :flag:`Universe Polymorphism` flag is on or + if the :attr:`universes(polymorphic)` attribute is used. + + .. exn:: Ill-formed template inductive declaration: not polymorphic on any universe. + + The attribute was used but the inductive definition does not + satisfy the criterion to be template polymorphic. + +.. attr:: universes(notemplate) + This attribute can be used to prevent an inductive type to be + template polymorphic, even if the :flag:`Auto Template + Polymorphism` flag is on. In practice, the rule **Ind-Family** is used by |Coq| only when all the inductive types of the inductive definition are declared with an arity diff --git a/doc/sphinx/language/coq-library.rst b/doc/sphinx/language/coq-library.rst index 39f2ccec29..acdd4408ed 100644 --- a/doc/sphinx/language/coq-library.rst +++ b/doc/sphinx/language/coq-library.rst @@ -1062,6 +1062,11 @@ Floating-point constants are parsed and pretty-printed as (17-digit) decimal constants. This ensures that the composition :math:`\text{parse} \circ \text{print}` amounts to the identity. +.. warn:: The constant @numeral is not a binary64 floating-point value. A closest value will be used and unambiguously printed @numeral. [inexact-float,parsing] + + Not all decimal constants are floating-point values. This warning + is generated when parsing such a constant (for instance ``0.1``). + .. example:: .. coqtop:: all diff --git a/doc/sphinx/language/core/index.rst b/doc/sphinx/language/core/index.rst new file mode 100644 index 0000000000..07dcfff444 --- /dev/null +++ b/doc/sphinx/language/core/index.rst @@ -0,0 +1,37 @@ +.. _core-language: + +============= +Core language +============= + +At the heart of the Coq proof assistant is the Coq kernel. While +users have access to a language with many convenient features such as +notations, implicit arguments, etc. (that are presented in the +:ref:`next chapter <extensions>`), such complex terms get translated +down to a core language (the Calculus of Inductive Constructions) that +the kernel understands, and which we present here. Furthermore, while +users can build proofs interactively using tactics (see Chapter +:ref:`writing-proofs`), the role of these tactics is to incrementally +build a "proof term" which the kernel will verify. More precisely, a +proof term is a term of the Calculus of Inductive Constructions whose +type corresponds to a theorem statement. The kernel is a type checker +which verifies that terms have their expected type. + +This separation between the kernel on the one hand and the elaboration +engine and tactics on the other hand follows what is known as the "de +Bruijn criterion" (keeping a small and well delimited trusted code +base within a proof assistant which can be much more complex). This +separation makes it possible to reduce the trust in the whole system +to trusting a smaller, critical component: the kernel. In particular, +users may rely on external plugins that provide advanced and complex +tactics without fear of these tactics being buggy, because the kernel +will have to check their output. + +.. toctree:: + :maxdepth: 1 + + ../gallina-specification-language + ../cic + ../../addendum/universe-polymorphism + ../../addendum/sprop + ../module-system diff --git a/doc/sphinx/language/extensions/index.rst b/doc/sphinx/language/extensions/index.rst new file mode 100644 index 0000000000..f22927d627 --- /dev/null +++ b/doc/sphinx/language/extensions/index.rst @@ -0,0 +1,26 @@ +.. _extensions: + +=================== +Language extensions +=================== + +Elaboration extends the language accepted by the Coq kernel to make it +easier to use. For example, this lets the user omit most type +annotations because they can be inferred, call functions with implicit +arguments which will be inferred as well, extend the syntax with +notations, factorize branches when pattern-matching, etc. In this +chapter, we present these language extensions and we give some +explanations on how this language is translated down to the core +language presented in the :ref:`previous chapter <core-language>`. + +.. toctree:: + :maxdepth: 1 + + ../gallina-extensions + ../../addendum/extended-pattern-matching + ../../user-extensions/syntax-extensions + ../../addendum/implicit-coercions + ../../addendum/type-classes + ../../addendum/canonical-structures + ../../addendum/program + ../../proof-engine/vernacular-commands diff --git a/doc/sphinx/language/gallina-extensions.rst b/doc/sphinx/language/gallina-extensions.rst index b9e181dd94..18b05e47d3 100644 --- a/doc/sphinx/language/gallina-extensions.rst +++ b/doc/sphinx/language/gallina-extensions.rst @@ -20,31 +20,39 @@ expressions. In this sense, the :cmd:`Record` construction allows defining .. _record_grammar: - .. productionlist:: sentence - record : `record_keyword` `record_body` with … with `record_body` - record_keyword : Record | Inductive | CoInductive - record_body : `ident` [ `binders` ] [: `sort` ] := [ `ident` ] { [ `field` ; … ; `field` ] }. - field : `ident` [ `binders` ] : `type` [ `decl_notations` ] - : `ident` [ `binders` ] [: `type` ] := `term` - -.. cmd:: {| Record | Structure } @inductive_definition {* with @inductive_definition } +.. cmd:: {| Record | Structure } @record_definition {* with @record_definition } :name: Record; Structure - The first identifier :token:`ident` is the name of the defined record and :token:`sort` is its - type. The optional identifier following ``:=`` is the name of its constructor. If it is omitted, - the default name :n:`Build_@ident`, where :token:`ident` is the record name, is used. If :token:`sort` is - omitted, the default sort is :math:`\Type`. The identifiers inside the brackets are the names of - fields. For a given field :token:`ident`, its type is :n:`forall {* @binder }, @type`. - Notice that the type of a particular identifier may depend on a previously-given identifier. Thus the - order of the fields is important. The record can depend as a whole on parameters :token:`binders` - and each field can also depend on its own :token:`binders`. Finally, notations can be attached to - fields using the :n:`decl_notations` annotation. + .. insertprodn record_definition field_body + + .. prodn:: + record_definition ::= {? > } @ident_decl {* @binder } {? : @type } {? @ident } %{ {*; @record_field } %} {? @decl_notations } + record_field ::= {* #[ {*, @attr } ] } @name {? @field_body } {? %| @num } {? @decl_notations } + field_body ::= {* @binder } @of_type + | {* @binder } @of_type := @term + | {* @binder } := @term + + Each :n:`@record_definition` defines a record named by :n:`@ident_decl`. + The constructor name is given by :n:`@ident`. + If the constructor name is not specified, then the default name :n:`Build_@ident` is used, + where :n:`@ident` is the record name. + + If :n:`@type` is + omitted, the default type is :math:`\Type`. The identifiers inside the brackets are the field names. + The type of each field :n:`@ident` is :n:`forall {* @binder }, @type`. + Notice that the type of an identifier can depend on a previously-given identifier. Thus the + order of the fields is important. :n:`@binder` parameters may be applied to the record as a whole + or to individual fields. + + Notations can be attached to fields using the :n:`@decl_notations` annotation. :cmd:`Record` and :cmd:`Structure` are synonyms. - This command supports the :attr:`universes(polymorphic)`, :attr:`universes(monomorphic)`, - :attr:`universes(template)`, :attr:`universes(notemplate)`, - :attr:`Cumulative`, :attr:`NonCumulative` and :attr:`Private` attributes. + This command supports the :attr:`universes(polymorphic)`, + :attr:`universes(monomorphic)`, :attr:`universes(template)`, + :attr:`universes(notemplate)`, :attr:`universes(cumulative)`, + :attr:`universes(noncumulative)` and :attr:`private(matching)` + attributes. More generally, a record may have explicitly defined (a.k.a. manifest) fields. For instance, we might have: @@ -353,16 +361,12 @@ can be alternatively written Definition not (b:bool) := if b then false else true. -More generally, for an inductive type with constructors |C_1| and |C_2|, -we have the following equivalence +More generally, for an inductive type with constructors :n:`@ident__1` +and :n:`@ident__2`, the following terms are equal: -:: +:n:`if @term__0 {? {? as @name } return @term } then @term__1 else @term__2` - if term [dep_ret_type] then term₁ else term₂ ≡ - match term [dep_ret_type] with - | C₁ _ … _ => term₁ - | C₂ _ … _ => term₂ - end +:n:`match @term__0 {? {? as @name } return @term } with | @ident__1 {* _ } => @term__1 | @ident__2 {* _ } => @term__2 end` .. example:: @@ -390,11 +394,13 @@ constructions. There are two variants of them. First destructuring let syntax ++++++++++++++++++++++++++++++ -The expression :g:`let (`\ |ident_1|:g:`, … ,` |ident_n|\ :g:`) :=` |term_0|\ :g:`in` |term_1| performs -case analysis on |term_0| which must be in an inductive type with one -constructor having itself :math:`n` arguments. Variables |ident_1| … |ident_n| are -bound to the :math:`n` arguments of the constructor in expression |term_1|. For -instance, the definition +The expression :n:`let ( {*, @ident__i } ) := @term__0 in @term__1` +performs case analysis on :n:`@term__0` whose type must be an +inductive type with exactly one constructor. The number of variables +:n:`@ident__i` must correspond to the number of arguments of this +contrustor. Then, in :n:`@term__1`, these variables are bound to the +arguments of the constructor in :n:`@term__0`. For instance, the +definition .. coqtop:: reset all @@ -409,7 +415,7 @@ can be alternatively written Definition fst (A B:Set) (p:A * B) := let (x, _) := p in x. Notice that reduction is different from regular :g:`let … in …` -construction since it happens only if |term_0| is in constructor form. +construction since it happens only if :n:`@term__0` is in constructor form. Otherwise, the reduction is blocked. The pretty-printing of a definition by matching on a irrefutable @@ -589,29 +595,82 @@ This example emphasizes what the printing settings offer. Advanced recursive functions ---------------------------- -The following experimental command is available when the ``FunInd`` library has been loaded via ``Require Import FunInd``: +The following command is available when the ``FunInd`` library has been loaded via ``Require Import FunInd``: -.. cmd:: Function @ident {* @binder} { @fixannot } : @type := @term +.. cmd:: Function @fix_definition {* with @fix_definition } - This command can be seen as a generalization of ``Fixpoint``. It is actually a wrapper - for several ways of defining a function *and other useful related - objects*, namely: an induction principle that reflects the recursive + This command is a generalization of :cmd:`Fixpoint`. It is a wrapper + for several ways of defining a function *and* other useful related + objects, namely: an induction principle that reflects the recursive structure of the function (see :tacn:`function induction`) and its fixpoint equality. - The meaning of this declaration is to define a function ident, - similarly to ``Fixpoint``. Like in ``Fixpoint``, the decreasing argument must + This defines a function similar to those defined by :cmd:`Fixpoint`. + As in :cmd:`Fixpoint`, the decreasing argument must be given (unless the function is not recursive), but it might not - necessarily be *structurally* decreasing. The point of the :n:`{ @fixannot }` annotation - is to name the decreasing argument *and* to describe which kind of - decreasing criteria must be used to ensure termination of recursive + necessarily be *structurally* decreasing. Use the :n:`@fixannot` clause + to name the decreasing argument *and* to describe which kind of + decreasing criteria to use to ensure termination of recursive calls. -The ``Function`` construction also enjoys the ``with`` extension to define -mutually recursive definitions. However, this feature does not work -for non structurally recursive functions. - -See the documentation of functional induction (:tacn:`function induction`) -and ``Functional Scheme`` (:ref:`functional-scheme`) for how to use -the induction principle to easily reason about the function. + :cmd:`Function` also supports the :n:`with` clause to create + mutually recursive definitions, however this feature is limited + to structurally recursive functions (i.e. when :n:`@fixannot` is a :n:`struct` + clause). + + See :tacn:`function induction` and :cmd:`Functional Scheme` for how to use + the induction principle to reason easily about the function. + + The form of the :n:`@fixannot` clause determines which definition mechanism :cmd:`Function` uses. + (Note that references to :n:`ident` below refer to the name of the function being defined.): + + * If :n:`@fixannot` is not specified, :cmd:`Function` + defines the nonrecursive function :token:`ident` as if it was declared with + :cmd:`Definition`. In addition, the following are defined: + + + :token:`ident`\ ``_rect``, :token:`ident`\ ``_rec`` and :token:`ident`\ ``_ind``, + which reflect the pattern matching structure of :token:`term` (see :cmd:`Inductive`); + + The inductive :n:`R_@ident` corresponding to the graph of :token:`ident` (silently); + + :token:`ident`\ ``_complete`` and :token:`ident`\ ``_correct`` which + are inversion information linking the function and its graph. + + * If :n:`{ struct ... }` is specified, :cmd:`Function` + defines the structural recursive function :token:`ident` as if it was declared + with :cmd:`Fixpoint`. In addition, the following are defined: + + + The same objects as above; + + The fixpoint equation of :token:`ident`: :n:`@ident`\ ``_equation``. + + * If :n:`{ measure ... }` or :n:`{ wf ... }` are specified, :cmd:`Function` + defines a recursive function by well-founded recursion. The module ``Recdef`` + of the standard library must be loaded for this feature. + + + :n:`{measure @one_term__1 {? @ident } {? @one_term__2 } }`\: where :n:`@ident` is the decreasing argument + and :n:`@one_term__1` is a function from the type of :n:`@ident` to :g:`nat` for which + the decreasing argument decreases (for the :g:`lt` order on :g:`nat`) + for each recursive call of the function. The parameters of the function are + bound in :n:`@one_term__1`. + + :n:`{wf @one_term @ident }`\: where :n:`@ident` is the decreasing argument and + :n:`@one_term` is an ordering relation on the type of :n:`@ident` (i.e. of type + `T`\ :math:`_{\sf ident}` → `T`\ :math:`_{\sf ident}` → ``Prop``) for which the decreasing argument + decreases for each recursive call of the function. The order must be well-founded. + The parameters of the function are bound in :n:`@one_term`. + + If the clause is ``measure`` or ``wf``, the user is left with some proof + obligations that will be used to define the function. These proofs + are: proofs that each recursive call is actually decreasing with + respect to the given criteria, and (if the criteria is `wf`) a proof + that the ordering relation is well-founded. Once proof obligations are + discharged, the following objects are defined: + + + The same objects as with the ``struct`` clause; + + The lemma :n:`@ident`\ ``_tcc`` which collects all proof obligations in one + property; + + The lemmas :n:`@ident`\ ``_terminate`` and :n:`@ident`\ ``_F`` which will be inlined + during extraction of :n:`@ident`. + + The way this recursive function is defined is the subject of several + papers by Yves Bertot and Antonia Balaa on the one hand, and Gilles + Barthe, Julien Forest, David Pichardie, and Vlad Rusu on the other + hand. .. note:: @@ -651,7 +710,7 @@ the induction principle to easily reason about the function. :token:`term` must be built as a *pure pattern matching tree* (:g:`match … with`) with applications only *at the end* of each branch. -Function does not support partial application of the function being +:cmd:`Function` does not support partial application of the function being defined. Thus, the following example cannot be accepted due to the presence of partial application of :g:`wrong` in the body of :g:`wrong`: @@ -684,7 +743,7 @@ terminating functions. will not be generated. This error happens generally when: - the definition uses pattern matching on dependent types, - which ``Function`` cannot deal with yet. + which :cmd:`Function` cannot deal with yet. - the definition is not a *pattern matching tree* as explained above. .. warn:: Cannot define principle(s) for @ident. @@ -698,65 +757,6 @@ terminating functions. .. seealso:: :ref:`functional-scheme` and :tacn:`function induction` -Depending on the ``{…}`` annotation, different definition mechanisms are -used by ``Function``. A more precise description is given below. - -.. cmdv:: Function @ident {* @binder } : @type := @term - - Defines the nonrecursive function :token:`ident` as if it was declared with - :cmd:`Definition`. Moreover the following are defined: - - + :token:`ident`\ ``_rect``, :token:`ident`\ ``_rec`` and :token:`ident`\ ``_ind``, - which reflect the pattern matching structure of :token:`term` (see :cmd:`Inductive`); - + The inductive :n:`R_@ident` corresponding to the graph of :token:`ident` (silently); - + :token:`ident`\ ``_complete`` and :token:`ident`\ ``_correct`` which - are inversion information linking the function and its graph. - -.. cmdv:: Function @ident {* @binder } { struct @ident } : @type := @term - - Defines the structural recursive function :token:`ident` as if declared - with :cmd:`Fixpoint`. Moreover the following are defined: - - + The same objects as above; - + The fixpoint equation of :token:`ident`: :token:`ident`\ ``_equation``. - -.. cmdv:: Function @ident {* @binder } { measure @term @ident } : @type := @term - Function @ident {* @binder } { wf @term @ident } : @type := @term - - Defines a recursive function by well-founded recursion. The module ``Recdef`` - of the standard library must be loaded for this feature. The ``{}`` - annotation is mandatory and must be one of the following: - - + :n:`{measure @term @ident }` with :token:`ident` being the decreasing argument - and :token:`term` being a function from type of :token:`ident` to :g:`nat` for which - value on the decreasing argument decreases (for the :g:`lt` order on :g:`nat`) - at each recursive call of :token:`term`. Parameters of the function are - bound in :token:`term`; - + :n:`{wf @term @ident }` with :token:`ident` being the decreasing argument and - :token:`term` an ordering relation on the type of :token:`ident` (i.e. of type - `T`\ :math:`_{\sf ident}` → `T`\ :math:`_{\sf ident}` → ``Prop``) for which the decreasing argument - decreases at each recursive call of :token:`term`. The order must be well-founded. - Parameters of the function are bound in :token:`term`. - - If the annotation is ``measure`` or ``fw``, the user is left with some proof - obligations that will be used to define the function. These proofs - are: proofs that each recursive call is actually decreasing with - respect to the given criteria, and (if the criteria is `wf`) a proof - that the ordering relation is well-founded. Once proof obligations are - discharged, the following objects are defined: - - + The same objects as with the struct; - + The lemma `ident`\ :math:`_{\sf tcc}` which collects all proof obligations in one - property; - + The lemmas `ident`\ :math:`_{\sf terminate}` and `ident`\ :math:`_{\sf F}` which is needed to be inlined - during extraction of ident. - - The way this recursive function is defined is the subject of several - papers by Yves Bertot and Antonia Balaa on the one hand, and Gilles - Barthe, Julien Forest, David Pichardie, and Vlad Rusu on the other - hand. Remark: Proof obligations are presented as several subgoals - belonging to a Lemma `ident`\ :math:`_{\sf tcc}`. - .. _section-mechanism: Section mechanism @@ -811,43 +811,44 @@ Sections create local contexts which can be shared across multiple definitions. .. cmd:: End @ident - This command closes the section named :token:`ident`. After closing of the - section, the local declarations (variables and local definitions, see :cmd:`Variable`) get + This command closes the section or module named :token:`ident`. + See :ref:`Terminating an interactive module or module type definition<terminating_module>` + for a description of its use with modules. + + After closing the + section, the local declarations (variables and local definitions, see :cmd:`Variable`) are *discharged*, meaning that they stop being visible and that all global objects defined in the section are generalized with respect to the variables and local definitions they each depended on in the section. - .. exn:: This is not the last opened section. + .. exn:: There is nothing to end. :undocumented: + .. exn:: Last block to end has name @ident. + :undocumented: + .. note:: Most commands, like :cmd:`Hint`, :cmd:`Notation`, option management, … which appear inside a section are canceled when the section is closed. -.. cmd:: Let @ident := @term - - This command binds the value :token:`term` to the name :token:`ident` in the - environment of the current section. The name :token:`ident` is accessible - only within the current section. When the section is closed, all persistent - definitions and theorems within it and depending on :token:`ident` - will be prefixed by the let-in definition :n:`let @ident := @term in`. - - .. exn:: @ident already exists. - :name: @ident already exists. (Let) - :undocumented: +.. cmd:: Let @ident @def_body + Let Fixpoint @fix_definition {* with @fix_definition } + Let CoFixpoint @cofix_definition {* with @cofix_definition } + :name: Let; Let Fixpoint; Let CoFixpoint - .. cmdv:: Let @ident {* @binder } {? : @type } := @term - :undocumented: + These commands behave like :cmd:`Definition`, :cmd:`Fixpoint` and :cmd:`CoFixpoint`, except that + the declared constant is local to the current section. + When the section is closed, all persistent + definitions and theorems within it that depend on the constant + will be wrapped with a :n:`@term_let` with the same declaration. - .. cmdv:: Let Fixpoint @ident @fix_body {* with @fix_body} - :name: Let Fixpoint - :undocumented: + As for :cmd:`Definition`, :cmd:`Fixpoint` and :cmd:`CoFixpoint`, + if :n:`@term` is omitted, :n:`@type` is required and Coq enters proof editing mode. + This can be used to define a term incrementally, in particular by relying on the :tacn:`refine` tactic. + In this case, the proof should be terminated with :cmd:`Defined` in order to define a constant + for which the computational behavior is relevant. See :ref:`proof-editing-mode`. - .. cmdv:: Let CoFixpoint @ident @fix_body {* with @fix_body} - :name: Let CoFixpoint - :undocumented: - -.. cmd:: Context {* @binder } +.. cmd:: Context {+ @binder } Declare variables in the context of the current section, like :cmd:`Variable`, but also allowing implicit variables, :ref:`implicit-generalization`, and @@ -867,255 +868,297 @@ Module system The module system provides a way of packaging related elements together, as well as a means of massive abstraction. - .. productionlist:: modules - module_type : `qualid` - : `module_type` with Definition `qualid` := `term` - : `module_type` with Module `qualid` := `qualid` - : `qualid` `qualid` … `qualid` - : !`qualid` `qualid` … `qualid` - module_binding : ( [Import|Export] `ident` … `ident` : `module_type` ) - module_bindings : `module_binding` … `module_binding` - module_expression : `qualid` … `qualid` - : !`qualid` … `qualid` - Syntax of modules +.. cmd:: Module {? {| Import | Export } } @ident {* @module_binder } {? @of_module_type } {? := {+<+ @module_expr_inl } } -In the syntax of module application, the ! prefix indicates that any -`Inline` directive in the type of the functor arguments will be ignored -(see the :cmd:`Module Type` command below). + .. insertprodn module_binder module_expr_inl + .. prodn:: + module_binder ::= ( {? {| Import | Export } } {+ @ident } : @module_type_inl ) + module_type_inl ::= ! @module_type + | @module_type {? @functor_app_annot } + functor_app_annot ::= [ inline at level @num ] + | [ no inline ] + module_type ::= @qualid + | ( @module_type ) + | @module_type @module_expr_atom + | @module_type with @with_declaration + with_declaration ::= Definition @qualid {? @univ_decl } := @term + | Module @qualid := @qualid + module_expr_atom ::= @qualid + | ( {+ @module_expr_atom } ) + of_module_type ::= : @module_type_inl + | {* <: @module_type_inl } + module_expr_inl ::= ! {+ @module_expr_atom } + | {+ @module_expr_atom } {? @functor_app_annot } -.. cmd:: Module @ident + Defines a module named :token:`ident`. See the examples :ref:`here<module_examples>`. - This command is used to start an interactive module named :token:`ident`. + The :n:`Import` and :n:`Export` flags specify whether the module should be automatically + imported or exported. -.. cmdv:: Module @ident {* @module_binding} + Specifying :n:`{* @module_binder }` starts a functor with + parameters given by the :n:`@module_binder`\s. (A *functor* is a function + from modules to modules.) - Starts an interactive functor with - parameters given by module_bindings. + .. todo: would like to find a better term than "interactive", not very descriptive -.. cmdv:: Module @ident : @module_type + :n:`@of_module_type` specifies the module type. :n:`{+ <: @module_type_inl }` + starts a module that satisfies each :n:`@module_type_inl`. - Starts an interactive module specifying its module type. + :n:`:= {+<+ @module_expr_inl }` specifies the body of a module or functor + definition. If it's not specified, then the module is defined *interactively*, + meaning that the module is defined as a series of commands terminated with :cmd:`End` + instead of in a single :cmd:`Module` command. + Interactively defining the :n:`@module_expr_inl`\s in a series of + :cmd:`Include` commands is equivalent to giving them all in a single + non-interactive :cmd:`Module` command. -.. cmdv:: Module @ident {* @module_binding} : @module_type + The ! prefix indicates that any assumption command (such as :cmd:`Axiom`) with an :n:`Inline` clause + in the type of the functor arguments will be ignored. - Starts an interactive functor with parameters given by the list of - :token:`module_bindings`, and output module type :token:`module_type`. + .. todo: What is an Inline directive? sb command but still unclear. Maybe referring to the + "inline" in functor_app_annot? or assumption_token Inline assum_list? -.. cmdv:: Module @ident <: {+<: @module_type } +.. cmd:: Module Type @ident {* @module_binder } {* <: @module_type_inl } {? := {+<+ @module_type_inl } } - Starts an interactive module satisfying each :token:`module_type`. + Defines a module type named :n:`@ident`. See the example :ref:`here<example_def_simple_module_type>`. - .. cmdv:: Module @ident {* @module_binding} <: {+<: @module_type }. + Specifying :n:`{* @module_binder }` starts a functor type with + parameters given by the :n:`@module_binder`\s. - Starts an interactive functor with parameters given by the list of - :token:`module_binding`. The output module type - is verified against each :token:`module_type`. + :n:`:= {+<+ @module_type_inl }` specifies the body of a module or functor type + definition. If it's not specified, then the module type is defined *interactively*, + meaning that the module type is defined as a series of commands terminated with :cmd:`End` + instead of in a single :cmd:`Module Type` command. + Interactively defining the :n:`@module_type_inl`\s in a series of + :cmd:`Include` commands is equivalent to giving them all in a single + non-interactive :cmd:`Module Type` command. -.. cmdv:: Module {| Import | Export } +.. _terminating_module: - Behaves like :cmd:`Module`, but automatically imports or exports the module. +**Terminating an interactive module or module type definition** -Reserved commands inside an interactive module -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Interactive modules are terminated with the :cmd:`End` command, which +is also used to terminate :ref:`Sections<section-mechanism>`. +:n:`End @ident` closes the interactive module or module type :token:`ident`. +If the module type was given, the command verifies that the content of the module +matches the module type. If the module is not a +functor, its components (constants, inductive types, submodules etc.) +are now available through the dot notation. -.. cmd:: Include @module +.. exn:: No such label @ident. + :undocumented: - Includes the content of module in the current - interactive module. Here module can be a module expression or a module - type expression. If module is a high-order module or module type - expression then the system tries to instantiate module by the current - interactive module. +.. exn:: Signature components for label @ident do not match. + :undocumented: -.. cmd:: Include {+<+ @module} +.. exn:: The field @ident is missing in @qualid. + :undocumented: - is a shortcut for the commands :n:`Include @module` for each :token:`module`. +.. |br| raw:: html -.. cmd:: End @ident + <br> - This command closes the interactive module :token:`ident`. If the module type - was given the content of the module is matched against it and an error - is signaled if the matching fails. If the module is basic (is not a - functor) its components (constants, inductive types, submodules etc.) - are now available through the dot notation. +.. note:: - .. exn:: No such label @ident. - :undocumented: + #. Interactive modules and module types can be nested. + #. Interactive modules and module types can't be defined inside of :ref:`sections<section-mechanism>`. + Sections can be defined inside of interactive modules and module types. + #. Hints and notations (:cmd:`Hint` and :cmd:`Notation` commands) can also appear inside interactive + modules and module types. Note that with module definitions like: - .. exn:: Signature components for label @ident do not match. - :undocumented: + :n:`Module @ident__1 : @module_type := @ident__2.` - .. exn:: This is not the last opened module. - :undocumented: + or -.. cmd:: Module @ident := @module_expression + :n:`Module @ident__1 : @module_type.` |br| + :n:`Include @ident__2.` |br| + :n:`End @ident__1.` - This command defines the module identifier :token:`ident` to be equal - to :token:`module_expression`. + hints and the like valid for :n:`@ident__1` are the ones defined in :n:`@module_type` + rather then those defined in :n:`@ident__2` (or the module body). + #. Within an interactive module type definition, the :cmd:`Parameter` command declares a + constant instead of definining a new axiom (which it does when not in a module type definition). + #. Assumptions such as :cmd:`Axiom` that include the :n:`Inline` clause will be automatically + expanded when the functor is applied, except when the function application is prefixed by ``!``. - .. cmdv:: Module @ident {* @module_binding} := @module_expression +.. cmd:: Include @module_type_inl {* <+ @module_expr_inl } - Defines a functor with parameters given by the list of :token:`module_binding` and body :token:`module_expression`. + Includes the content of module(s) in the current + interactive module. Here :n:`@module_type_inl` can be a module expression or a module + type expression. If it is a high-order module or module type + expression then the system tries to instantiate :n:`@module_type_inl` with the current + interactive module. - .. cmdv:: Module @ident {* @module_binding} : @module_type := @module_expression + Including multiple modules is a single :cmd:`Include` is equivalent to including each module + in a separate :cmd:`Include` command. - Defines a functor with parameters given by the list of :token:`module_binding` (possibly none), and output module type :token:`module_type`, - with body :token:`module_expression`. +.. cmd:: Include Type {+<+ @module_type_inl } - .. cmdv:: Module @ident {* @module_binding} <: {+<: @module_type} := @module_expression + .. deprecated:: 8.3 - Defines a functor with parameters given by module_bindings (possibly none) with body :token:`module_expression`. - The body is checked against each :n:`@module_type__i`. + Use :cmd:`Include` instead. - .. cmdv:: Module @ident {* @module_binding} := {+<+ @module_expression} +.. cmd:: Declare Module {? {| Import | Export } } @ident {* @module_binder } : @module_type_inl - is equivalent to an interactive module where each :token:`module_expression` is included. + Declares a module :token:`ident` of type :token:`module_type_inl`. -.. cmd:: Module Type @ident + If :n:`@module_binder`\s are specified, declares a functor with parameters given by the list of + :token:`module_binder`\s. - This command is used to start an interactive module type :token:`ident`. +.. cmd:: Import {+ @qualid } - .. cmdv:: Module Type @ident {* @module_binding} + If :token:`qualid` denotes a valid basic module (i.e. its module type is a + signature), makes its components available by their short names. - Starts an interactive functor type with parameters given by :token:`module_bindings`. + .. example:: + .. coqtop:: reset in -Reserved commands inside an interactive module type: -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + Module Mod. + Definition T:=nat. + Check T. + End Mod. + Check Mod.T. -.. cmd:: Include @module + .. coqtop:: all - Same as ``Include`` inside a module. + Fail Check T. + Import Mod. + Check T. -.. cmd:: Include {+<+ @module} + Some features defined in modules are activated only when a module is + imported. This is for instance the case of notations (see :ref:`Notations`). - This is a shortcut for the command :n:`Include @module` for each :token:`module`. + Declarations made with the :attr:`local` attribute are never imported by the :cmd:`Import` + command. Such declarations are only accessible through their fully + qualified name. -.. cmd:: @assumption_token Inline @assums - :name: Inline + .. example:: - The instance of this assumption will be automatically expanded at functor application, except when - this functor application is prefixed by a ``!`` annotation. + .. coqtop:: in -.. cmd:: End @ident + Module A. + Module B. + Local Definition T := nat. + End B. + End A. + Import A. - This command closes the interactive module type :token:`ident`. + .. coqtop:: all fail - .. exn:: This is not the last opened module type. - :undocumented: + Check B.T. -.. cmd:: Module Type @ident := @module_type +.. cmd:: Export {+ @qualid } + :name: Export - Defines a module type :token:`ident` equal to :token:`module_type`. + Similar to :cmd:`Import`, except that when the module containing this command + is imported, the :n:`{+ @qualid }` are imported as well. - .. cmdv:: Module Type @ident {* @module_binding} := @module_type + .. exn:: @qualid is not a module. + :undocumented: - Defines a functor type :token:`ident` specifying functors taking arguments :token:`module_bindings` and - returning :token:`module_type`. + .. warn:: Trying to mask the absolute name @qualid! + :undocumented: - .. cmdv:: Module Type @ident {* @module_binding} := {+<+ @module_type } +.. cmd:: Print Module @qualid - is equivalent to an interactive module type were each :token:`module_type` is included. + Prints the module type and (optionally) the body of the module :n:`@qualid`. -.. cmd:: Declare Module @ident : @module_type +.. cmd:: Print Module Type @qualid - Declares a module :token:`ident` of type :token:`module_type`. + Prints the module type corresponding to :n:`@qualid`. - .. cmdv:: Declare Module @ident {* @module_binding} : @module_type +.. flag:: Short Module Printing - Declares a functor with parameters given by the list of :token:`module_binding` and output module type - :token:`module_type`. + This flag (off by default) disables the printing of the types of fields, + leaving only their names, for the commands :cmd:`Print Module` and + :cmd:`Print Module Type`. -.. example:: +.. _module_examples: - Let us define a simple module. +Examples +~~~~~~~~ - .. coqtop:: all +.. example:: Defining a simple module interactively - Module M. + .. coqtop:: in + Module M. Definition T := nat. - Definition x := 0. - Definition y : bool. + .. coqtop:: all + Definition y : bool. exact true. - Defined. + .. coqtop:: in + Defined. End M. -Inside a module one can define constants, prove theorems and do any -other things that can be done in the toplevel. Components of a closed +Inside a module one can define constants, prove theorems and do anything +else that can be done in the toplevel. Components of a closed module can be accessed using the dot notation: .. coqtop:: all Print M.x. -A simple module type: - -.. coqtop:: all - - Module Type SIG. - - Parameter T : Set. - - Parameter x : T. - - End SIG. +.. _example_def_simple_module_type: -Now we can create a new module from M, giving it a less precise -specification: the y component is dropped as well as the body of x. - -.. coqtop:: all +.. example:: Defining a simple module type interactively - Module N : SIG with Definition T := nat := M. - - Print N.T. - - Print N.x. - - Fail Print N.y. - -.. reset to remove N (undo in last coqtop block doesn't seem to do that), invisibly redefine M, SIG -.. coqtop:: none reset - - Module M. + .. coqtop:: in - Definition T := nat. + Module Type SIG. + Parameter T : Set. + Parameter x : T. + End SIG. - Definition x := 0. +.. _example_filter_module: - Definition y : bool. +.. example:: Creating a new module that omits some items from an existing module - exact true. + Since :n:`SIG`, the type of the new module :n:`N`, doesn't define :n:`y` or + give the body of :n:`x`, which are not included in :n:`N`. - Defined. + .. coqtop:: all - End M. + Module N : SIG with Definition T := nat := M. + Print N.T. + Print N.x. + Fail Print N.y. - Module Type SIG. + .. reset to remove N (undo in last coqtop block doesn't seem to do that), invisibly redefine M, SIG + .. coqtop:: none reset - Parameter T : Set. + Module M. + Definition T := nat. + Definition x := 0. + Definition y : bool. + exact true. + Defined. + End M. - Parameter x : T. + Module Type SIG. + Parameter T : Set. + Parameter x : T. + End SIG. - End SIG. - -The definition of :g:`N` using the module type expression :g:`SIG` with +The following definition of :g:`N` using the module type expression :g:`SIG` with :g:`Definition T := nat` is equivalent to the following one: -.. coqtop:: all +.. todo: what is other definition referred to above? + "Module N' : SIG with Definition T := nat. End N`." is not it. - Module Type SIG'. +.. coqtop:: in + Module Type SIG'. Definition T : Set := nat. - Parameter x : T. - End SIG'. Module N : SIG' := M. @@ -1124,165 +1167,58 @@ If we just want to be sure that our implementation satisfies a given module type without restricting the interface, we can use a transparent constraint -.. coqtop:: all +.. coqtop:: in Module P <: SIG := M. - Print P.y. - -Now let us create a functor, i.e. a parametric module - -.. coqtop:: all - - Module Two (X Y: SIG). - - Definition T := (X.T * Y.T)%type. - - Definition x := (X.x, Y.x). - - End Two. - -and apply it to our modules and do some computations: - .. coqtop:: all - Module Q := Two M N. - - Eval compute in (fst Q.x + snd Q.x). - -In the end, let us define a module type with two sub-modules, sharing -some of the fields and give one of its possible implementations: - -.. coqtop:: all + Print P.y. - Module Type SIG2. +.. example:: Creating a functor (a module with parameters) - Declare Module M1 : SIG. + .. coqtop:: in - Module M2 <: SIG. + Module Two (X Y: SIG). + Definition T := (X.T * Y.T)%type. + Definition x := (X.x, Y.x). + End Two. - Definition T := M1.T. + and apply it to our modules and do some computations: - Parameter x : T. + .. coqtop:: in - End M2. - End SIG2. + Module Q := Two M N. - Module Mod <: SIG2. + .. coqtop:: all - Module M1. + Eval compute in (fst Q.x + snd Q.x). - Definition T := nat. +.. example:: A module type with two sub-modules, sharing some fields - Definition x := 1. + .. coqtop:: in - End M1. + Module Type SIG2. + Declare Module M1 : SIG. + Module M2 <: SIG. + Definition T := M1.T. + Parameter x : T. + End M2. + End SIG2. - Module M2 := M. + .. coqtop:: in - End Mod. + Module Mod <: SIG2. + Module M1. + Definition T := nat. + Definition x := 1. + End M1. + Module M2 := M. + End Mod. Notice that ``M`` is a correct body for the component ``M2`` since its ``T`` -component is equal ``nat`` and hence ``M1.T`` as specified. - -.. note:: - - #. Modules and module types can be nested components of each other. - #. One can have sections inside a module or a module type, but not a - module or a module type inside a section. - #. Commands like :cmd:`Hint` or :cmd:`Notation` can also appear inside modules and - module types. Note that in case of a module definition like: - - :: - - Module N : SIG := M. - - or:: - - Module N : SIG. … End N. - - hints and the like valid for ``N`` are not those defined in ``M`` - (or the module body) but the ones defined in ``SIG``. - - -.. _import_qualid: - -.. cmd:: Import @qualid - - If :token:`qualid` denotes a valid basic module (i.e. its module type is a - signature), makes its components available by their short names. - - .. example:: - - .. coqtop:: reset all - - Module Mod. - - Definition T:=nat. - - Check T. - - End Mod. - - Check Mod.T. - - Fail Check T. - - Import Mod. - - Check T. - - Some features defined in modules are activated only when a module is - imported. This is for instance the case of notations (see :ref:`Notations`). - - Declarations made with the ``Local`` flag are never imported by the :cmd:`Import` - command. Such declarations are only accessible through their fully - qualified name. - - .. example:: - - .. coqtop:: all - - Module A. - - Module B. - - Local Definition T := nat. - - End B. - - End A. - - Import A. - - Fail Check B.T. - - .. cmdv:: Export @qualid - :name: Export - - When the module containing the command ``Export`` qualid - is imported, qualid is imported as well. - - .. exn:: @qualid is not a module. - :undocumented: - - .. warn:: Trying to mask the absolute name @qualid! - :undocumented: - -.. cmd:: Print Module @ident - - Prints the module type and (optionally) the body of the module :token:`ident`. - -.. cmd:: Print Module Type @ident - - Prints the module type corresponding to :token:`ident`. - -.. flag:: Short Module Printing - - This flag (off by default) disables the printing of the types of fields, - leaving only their names, for the commands :cmd:`Print Module` and - :cmd:`Print Module Type`. +component is ``nat`` as specified for ``M1.T``. Libraries and qualified names --------------------------------- @@ -1345,7 +1281,7 @@ also each time a new declaration is added to the context. An absolute name is called visible from a given short or partially qualified name when this latter name is enough to denote it. This means that the short or partially qualified name is mapped to the absolute name in -|Coq| name table. Definitions flagged as Local are only accessible with +|Coq| name table. Definitions with the :attr:`local` attribute are only accessible with their fully qualified name (see :ref:`gallina-definitions`). It may happen that a visible name is hidden by the short name or a @@ -1412,7 +1348,7 @@ with the same physical-to-logical translation and with an empty logical prefix. The command line option ``-R`` is a variant of ``-Q`` which has the strictly same behavior regarding loadpaths, but which also makes the corresponding ``.vo`` files available through their short names in a way -not unlike the ``Import`` command (see :ref:`here <import_qualid>`). For instance, ``-R path Lib`` +similar to the :cmd:`Import` command. For instance, ``-R path Lib`` associates to the file ``/path/fOO/Bar/File.vo`` the logical name ``Lib.fOO.Bar.File``, but allows this file to be accessed through the short names ``fOO.Bar.File,Bar.File`` and ``File``. If several files with @@ -1601,6 +1537,12 @@ this, *a priori* and *a posteriori*. Implicit Argument Binders +++++++++++++++++++++++++ +.. insertprodn implicit_binders implicit_binders + +.. prodn:: + implicit_binders ::= %{ {+ @name } {? : @type } %} + | [ {+ @name } {? : @type } ] + In the first setting, one wants to explicitly give the implicit arguments of a declared object as part of its definition. To do this, one has to surround the bindings of implicit arguments by curly @@ -1694,48 +1636,79 @@ Declaring Implicit Arguments -.. cmd:: Arguments @qualid {* {| [ @name ] | { @name } | @name } } - :name: Arguments (implicits) - - This command is used to set implicit arguments *a posteriori*, - where the list of possibly bracketed :token:`name` is a prefix of the list of - arguments of :token:`qualid` where the ones to be declared implicit are - surrounded by square brackets and the ones to be declared as maximally - inserted implicits are surrounded by curly braces. - - After the above declaration is issued, implicit arguments can just - (and have to) be skipped in any expression involving an application - of :token:`qualid`. - -.. cmd:: Arguments @qualid : clear implicits - :name: Arguments (clear implicits) - - This command clears implicit arguments. - -.. cmdv:: Global Arguments @qualid {* {| [ @name ] | { @name } | @name } } - - This command is used to recompute the implicit arguments of - :token:`qualid` after ending of the current section if any, enforcing the - implicit arguments known from inside the section to be the ones - declared by the command. - -.. cmdv:: Local Arguments @qualid {* {| [ @name ] | { @name } | @name } } - - When in a module, tell not to activate the - implicit arguments of :token:`qualid` declared by this command to contexts that - require the module. - -.. cmdv:: {? {| Global | Local } } Arguments @qualid {*, {+ {| [ @name ] | { @name } | @name } } } +.. cmd:: Arguments @smart_qualid {* @argument_spec_block } {* , {* @more_implicits_block } } {? : {+, @arguments_modifier } } + :name: Arguments + + .. insertprodn smart_qualid arguments_modifier + + .. prodn:: + smart_qualid ::= @qualid + | @by_notation + by_notation ::= @string {? % @ident } + argument_spec_block ::= @argument_spec + | / + | & + | ( {+ @argument_spec } ) {? % @ident } + | [ {+ @argument_spec } ] {? % @ident } + | %{ {+ @argument_spec } %} {? % @ident } + argument_spec ::= {? ! } @name {? % @ident } + more_implicits_block ::= @name + | [ {+ @name } ] + | %{ {+ @name } %} + arguments_modifier ::= simpl nomatch + | simpl never + | default implicits + | clear bidirectionality hint + | clear implicits + | clear scopes + | clear scopes and implicits + | clear implicits and scopes + | rename + | assert + | extra scopes + + This command sets implicit arguments *a posteriori*, + where the list of :n:`@name`\s is a prefix of the list of + arguments of :n:`@smart_qualid`. Arguments in square + brackets are declared as implicit and arguments in curly brackets are declared as + maximally inserted. + + After the command is issued, implicit arguments can and must be + omitted in any expression that applies :token:`qualid`. + + This command supports the :attr:`local` and :attr:`global` attributes. + Default behavior is to limit the effect to the current section but also to + extend their effect outside the current module or library file. + Applying :attr:`local` limits the effect of the command to the current module if + it's not in a section. Applying :attr:`global` within a section extends the + effect outside the current sections and current module if the command occurs. + + A command containing :n:`@argument_spec_block & @argument_spec_block` + provides :ref:`bidirectionality_hints`. + + Use the :n:`@more_implicits_block` to specify multiple implicit arguments declarations + for names of constants, inductive types, constructors and lemmas that can only be + applied to a fixed number of arguments (excluding, for instance, + constants whose type is polymorphic). + The longest applicable list of implicit arguments will be used to select which + implicit arguments are inserted. + For printing, the omitted arguments are the ones of the longest list of implicit + arguments of the sequence. See the example :ref:`here<example_more_implicits>`. + + The :n:`@arguments_modifier` values have various effects: + + * :n:`clear implicits` - clears implicit arguments + * :n:`default implicits` - automatically determine the implicit arguments of the object. + See :ref:`auto_decl_implicit_args`. + * :n:`rename` - rename implicit arguments for the object + * :n:`assert` - assert that the object has the expected number of arguments with the + expected names. See the example here: :ref:`renaming_implicit_arguments`. + +.. exn:: The / modifier may only occur once. + :undocumented: - For names of constants, inductive types, - constructors, lemmas which can only be applied to a fixed number of - arguments (this excludes for instance constants whose type is - polymorphic), multiple implicit arguments declarations can be given. - Depending on the number of arguments qualid is applied to in practice, - the longest applicable list of implicit arguments is used to select - which implicit arguments are inserted. For printing, the omitted - arguments are the ones of the longest list of implicit arguments of - the sequence. +.. exn:: The & modifier may only occur once. + :undocumented: .. example:: @@ -1765,40 +1738,34 @@ Declaring Implicit Arguments Check (fun l:list (list nat) => map length l). +.. _example_more_implicits: + +.. example:: Multiple implicit arguments with :n:`@more_implicits_block` + + .. coqtop:: all + Arguments map [A B] f l, [A] B f l, A B f l. Check (fun l => map length l = map (list nat) nat length l). .. note:: - To know which are the implicit arguments of an object, use the - command :cmd:`Print Implicit` (see :ref:`displaying-implicit-args`). + Use the :cmd:`Print Implicit` command to see the implicit arguments + of an object (see :ref:`displaying-implicit-args`). + +.. _auto_decl_implicit_args: Automatic declaration of implicit arguments ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -.. cmd:: Arguments @qualid : default implicits - :name: Arguments (default implicits) - - This command tells |Coq| to automatically detect what are the implicit arguments of a - defined object. + The :n:`default implicits @arguments_modifier` clause tells |Coq| to automatically determine the + implicit arguments of the object. - The auto-detection is governed by flags telling if strict, + Auto-detection is governed by flags specifying whether strict, contextual, or reversible-pattern implicit arguments must be - considered or not (see :ref:`controlling-strict-implicit-args`, :ref:`controlling-strict-implicit-args`, - :ref:`controlling-rev-pattern-implicit-args`, and also :ref:`controlling-insertion-implicit-args`). - - .. cmdv:: Global Arguments @qualid : default implicits - - Tell to recompute the - implicit arguments of qualid after ending of the current section if - any. + considered or not (see :ref:`controlling-strict-implicit-args`, :ref:`controlling-contextual-implicit-args`, + :ref:`controlling-rev-pattern-implicit-args` and also :ref:`controlling-insertion-implicit-args`). - .. cmdv:: Local Arguments @qualid : default implicits - - When in a module, tell not to activate the implicit arguments of :token:`qualid` computed by this - declaration to contexts that requires the module. - -.. example:: +.. example:: Default implicits .. coqtop:: reset all @@ -1955,21 +1922,12 @@ the hiding of implicit arguments for a single function application using the Check (p (x:=a) (y:=b) r1 (z:=c) r2). +.. _renaming_implicit_arguments: + Renaming implicit arguments ~~~~~~~~~~~~~~~~~~~~~~~~~~~ -.. cmd:: Arguments @qualid {* @name} : rename - :name: Arguments (rename) - - This command is used to redefine the names of implicit arguments. - -.. cmd:: Arguments @qualid {* @name} : assert - :name: Arguments (assert) - - This command is used to assert that a given object has the expected - number of arguments and that these arguments are named as expected. - -.. example:: (continued) +.. example:: (continued) Renaming implicit arguments .. coqtop:: all @@ -1983,27 +1941,27 @@ Renaming implicit arguments .. _displaying-implicit-args: -Displaying what the implicit arguments are -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Displaying implicit arguments +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -.. cmd:: Print Implicit @qualid +.. cmd:: Print Implicit @smart_qualid - Use this command to display the implicit arguments associated to an object, - and to know if each of them is to be used maximally or not. + Displays the implicit arguments associated with an object, + identifying which arguments are applied maximally or not. -Explicit displaying of implicit arguments for pretty-printing -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Displaying implicit arguments when pretty-printing +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ .. flag:: Printing Implicit - By default, the basic pretty-printing rules hide the inferable implicit + By default, the basic pretty-printing rules hide the inferrable implicit arguments of an application. Turn this flag on to force printing all implicit arguments. .. flag:: Printing Implicit Defensive - By default, the basic pretty-printing rules display the implicit + By default, the basic pretty-printing rules display implicit arguments that are not detected as strict implicit arguments. This “defensive” mode can quickly make the display cumbersome so this can be deactivated by turning this flag off. @@ -2053,12 +2011,19 @@ applied to an unknown structure instance (an implicit argument) and a value. The complete documentation of canonical structures can be found in :ref:`canonicalstructures`; here only a simple example is given. -.. cmd:: {? Local | #[local] } Canonical {? Structure } @qualid - :name: Canonical Structure +.. cmd:: Canonical {? Structure } @smart_qualid + Canonical {? Structure } @ident_decl @def_body + :name: Canonical Structure; _ + + The first form of this command declares an existing :n:`@smart_qualid` as a + canonical instance of a structure (a record). + + The second form defines a new constant as if the :cmd:`Definition` command + had been used, then declares it as a canonical instance as if the first + form had been used on the defined object. - This command declares :token:`qualid` as a canonical instance of a - structure (a record). When the :g:`#[local]` attribute is given the effect - stops at the end of the :g:`Section` containig it. + This command supports the :attr:`local` attribute. When used, the + structure is canonical only within the :cmd:`Section` containing it. Assume that :token:`qualid` denotes an object ``(Build_struct`` |c_1| … |c_n| ``)`` in the structure :g:`struct` of which the fields are |x_1|, …, |x_n|. @@ -2106,9 +2071,12 @@ in :ref:`canonicalstructures`; here only a simple example is given. If a same field occurs in several canonical structures, then only the structure declared first as canonical is considered. - .. note:: - To prevent a field from being involved in the inference of canonical instances, - its declaration can be annotated with the :g:`#[canonical(false)]` attribute. + .. attr:: canonical(false) + + To prevent a field from being involved in the inference of + canonical instances, its declaration can be annotated with the + :attr:`canonical(false)` attribute (cf. the syntax of + :n:`@record_field`). .. example:: @@ -2121,12 +2089,13 @@ in :ref:`canonicalstructures`; here only a simple example is given. See :ref:`canonicalstructures` for a more realistic example. - .. cmdv:: {? Local | #[local] } Canonical {? Structure } @ident {? : @type } := @term +.. attr:: canonical - This is equivalent to a regular definition of :token:`ident` followed by the - declaration :n:`Canonical @ident`. + This attribute can decorate a :cmd:`Definition` or :cmd:`Let` command. + It is equivalent to having a :cmd:`Canonical Structure` declaration just + after the command. -.. cmd:: Print Canonical Projections {* @ident} +.. cmd:: Print Canonical Projections {* @smart_qualid } This displays the list of global names that are components of some canonical structure. For each of them, the canonical structure of @@ -2159,13 +2128,21 @@ It is possible to bind variable names to a given type (e.g. in a development using arithmetic, it may be convenient to bind the names :g:`n` or :g:`m` to the type :g:`nat` of natural numbers). -.. cmd:: Implicit Types {+ @ident } : @type +.. cmd:: Implicit {| Type | Types } @reserv_list + :name: Implicit Type; Implicit Types + + .. insertprodn reserv_list simple_reserv + + .. prodn:: + reserv_list ::= {+ ( @simple_reserv ) } + | @simple_reserv + simple_reserv ::= {+ @ident } : @type - The effect of the command is to automatically set the type of bound + Sets the type of bound variables starting with :token:`ident` (either :token:`ident` itself or :token:`ident` followed by one or more single quotes, underscore or - digits) to be :token:`type` (unless the bound variable is already declared - with an explicit type in which case, this latter type is considered). + digits) to :token:`type` (unless the bound variable is already declared + with an explicit type, in which case, that type will be used). .. example:: @@ -2181,14 +2158,6 @@ or :g:`m` to the type :g:`nat` of natural numbers). Lemma cons_inj_bool : forall (m n:bool) l, n :: l = m :: l -> n = m. Abort. -.. cmdv:: Implicit Type @ident : @type - - This is useful for declaring the implicit type of a single variable. - -.. cmdv:: Implicit Types {+ ( {+ @ident } : @type ) } - - Adds blocks of implicit types with different specifications. - .. flag:: Printing Use Implicit Types By default, the type of bound variables is not printed when @@ -2208,9 +2177,21 @@ Implicit generalization .. index:: `[! ] .. index:: `(! ) +.. insertprodn generalizing_binder typeclass_constraint + +.. prodn:: + generalizing_binder ::= `( {+, @typeclass_constraint } ) + | `%{ {+, @typeclass_constraint } %} + | `[ {+, @typeclass_constraint } ] + typeclass_constraint ::= {? ! } @term + | %{ @name %} : {? ! } @term + | @name : {? ! } @term + + Implicit generalization is an automatic elaboration of a statement with free variables into a closed statement where these variables are -quantified explicitly. +quantified explicitly. Use the :cmd:`Generalizable` command to designate +which variables should be generalized. It is activated for a binder by prefixing a \`, and for terms by surrounding it with \`{ }, or \`[ ] or \`( ). @@ -2272,31 +2253,26 @@ Multiple binders can be merged using ``,`` as a separator: Check (forall `{Commutative A, Hnat : !Commutative nat}, True). -One can control the set of generalizable identifiers with -the ``Generalizable`` vernacular command to avoid unexpected -generalizations when mistyping identifiers. There are several commands -that specify which variables should be generalizable. - -.. cmd:: Generalizable All Variables - - All variables are candidate for - generalization if they appear free in the context under a - generalization delimiter. This may result in confusing errors in case - of typos. In such cases, the context will probably contain some - unexpected generalized variable. +.. cmd:: Generalizable {| {| Variable | Variables } {+ @ident } | All Variables | No Variables } -.. cmd:: Generalizable No Variables + Controls the set of generalizable identifiers. By default, no variables are + generalizable. - Disable implicit generalization entirely. This is the default behavior. + This command supports the :attr:`global` attribute. -.. cmd:: Generalizable {| Variable | Variables } {+ @ident } + The :n:`{| Variable | Variables } {+ @ident }` form allows generalization of only the given :n:`@ident`\s. + Using this command multiple times adds to the allowed identifiers. The other forms clear + the list of :n:`@ident`\s. - Allow generalization of the given identifiers only. Calling this command multiple times - adds to the allowed identifiers. + The :n:`All Variables` form generalizes all free variables in + the context that appear under a + generalization delimiter. This may result in confusing errors in case + of typos. In such cases, the context will probably contain some + unexpected generalized variables. -.. cmd:: Global Generalizable + The :n:`No Variables` form disables implicit generalization entirely. This is + the default behavior (before any :cmd:`Generalizable` command has been entered). - Allows exporting the choice of generalizable variables. .. _Coercions: @@ -2308,7 +2284,7 @@ which they reside into another one. A *class* is either a sort (denoted by the keyword ``Sortclass``), a product type (denoted by the keyword ``Funclass``), or a type constructor (denoted by its name), e.g. an inductive type or any constant with a type of the form -``forall (`` |x_1| : |A_1| ) … ``(``\ |x_n| : |A_n|\ ``)``, `s` where `s` is a sort. +:n:`forall {+ @binder }, @sort`. Then the user is able to apply an object that is not a function, but can be coerced to a function, and more generally to consider that a @@ -2350,43 +2326,36 @@ Printing universes terms apparently identical but internally different in the Calculus of Inductive Constructions. -.. cmd:: Print {? Sorted} Universes +.. cmd:: Print {? Sorted } Universes {? Subgraph ( {* @qualid } ) } {? @string } :name: Print Universes This command can be used to print the constraints on the internal level of the occurrences of :math:`\Type` (see :ref:`Sorts`). - If the ``Sorted`` keyword is present, each universe will be made + The :n:`Subgraph` clause limits the printed graph to the requested names (adjusting + constraints to preserve the implied transitive constraints between + kept universes). + + The :n:`Sorted` clause makes each universe equivalent to a numbered label reflecting its level (with a linear ordering) in the universe hierarchy. - .. cmdv:: Print {? Sorted} Universes @string - - This variant accepts an optional output filename. - - If :token:`string` ends in ``.dot`` or ``.gv``, the constraints are printed in the DOT - language, and can be processed by Graphviz tools. The format is - unspecified if `string` doesn’t end in ``.dot`` or ``.gv``. - -.. cmdv:: Print Universes Subgraph({+ @qualid }) - :name: Print Universes Subgraph - - Prints the graph restricted to the requested names (adjusting - constraints to preserve the implied transitive constraints between - kept universes). + :n:`@string` is an optional output filename. + If :n:`@string` ends in ``.dot`` or ``.gv``, the constraints are printed in the DOT + language, and can be processed by Graphviz tools. The format is + unspecified if `string` doesn’t end in ``.dot`` or ``.gv``. .. _existential-variables: Existential variables --------------------- -.. insertprodn term_evar evar_binding +.. insertprodn term_evar term_evar .. prodn:: term_evar ::= ?[ @ident ] | ?[ ?@ident ] - | ?@ident {? @%{ {+; @evar_binding } %} } - evar_binding ::= @ident := @term + | ?@ident {? @%{ {+; @ident := @term } %} } |Coq| terms can include existential variables which represents unknown subterms to eventually be replaced by actual subterms. @@ -2578,6 +2547,8 @@ values (of type :g:`float`) written in hexadecimal notation and wrapped into the :g:`Float64.of_float` constructor, e.g.: :g:`Float64.of_float (0x1p+0)`. +.. _bidirectionality_hints: + Bidirectionality hints ---------------------- @@ -2588,15 +2559,14 @@ Bidirectionality hints make it possible to specify that after type-checking the first arguments of an application, typing information should be propagated from the context to help inferring the types of the remaining arguments. -.. cmd:: Arguments @qualid {* @ident__1 } & {* @ident__2} - :name: Arguments (bidirectionality hints) - - This commands tells the typechecking algorithm, when type-checking - applications of :n:`@qualid`, to first type-check the arguments in - :n:`@ident__1` and then propagate information from the typing context to - type-check the remaining arguments (in :n:`@ident__2`). +An :cmd:`Arguments` command containing :n:`@argument_spec_block__1 & @argument_spec_block__2` +provides :ref:`bidirectionality_hints`. +It tells the typechecking algorithm, when type-checking +applications of :n:`@qualid`, to first type-check the arguments in +:n:`@argument_spec_block__1` and then propagate information from the typing context to +type-check the remaining arguments (in :n:`@argument_spec_block__2`). -.. example:: +.. example:: Bidirectionality hints In a context where a coercion was declared from ``bool`` to ``nat``: diff --git a/doc/sphinx/language/gallina-specification-language.rst b/doc/sphinx/language/gallina-specification-language.rst index 4f0cf5f815..f4592f8f37 100644 --- a/doc/sphinx/language/gallina-specification-language.rst +++ b/doc/sphinx/language/gallina-specification-language.rst @@ -117,7 +117,7 @@ Other tokens ! #[ % & ' ( () (bfs) (dfs) ) * ** + , - -> . .( .. ... / : ::= := :> :>> ; < <+ <- <: - <<: <= = => > >-> >= ? @ @{ [ [= ] _ _eqn + <<: <= = => > >-> >= ? @ @{ [ [= ] _ `( `{ { {| | |- || } When multiple tokens match the beginning of a sequence of characters, @@ -290,7 +290,7 @@ More on sorts can be found in Section :ref:`sorts`. Binders ------- -.. insertprodn open_binders typeclass_constraint +.. insertprodn open_binders binder .. prodn:: open_binders ::= {+ @name } : @term @@ -300,16 +300,10 @@ Binders binder ::= @name | ( {+ @name } : @type ) | ( @name {? : @type } := @term ) + | @implicit_binders + | @generalizing_binder | ( @name : @type %| @term ) - | %{ {+ @name } {? : @type } %} - | [ {+ @name } {? : @type } ] - | `( {+, @typeclass_constraint } ) - | `%{ {+, @typeclass_constraint } %} - | `[ {+, @typeclass_constraint } ] | ' @pattern0 - typeclass_constraint ::= {? ! } @term - | %{ @name %} : {? ! } @term - | @name : {? ! } @term Various constructions such as :g:`fun`, :g:`forall`, :g:`fix` and :g:`cofix` *bind* variables. A binding is represented by an identifier. If the binding @@ -620,6 +614,10 @@ The association of a single fixpoint and a local definition have a special syntax: :n:`let fix @ident {* @binder } := @term in` stands for :n:`let @ident := fix @ident {* @binder } := @term in`. The same applies for co-fixpoints. +Some options of :n:`@fixannot` are only supported in specific constructs. :n:`fix` and :n:`let fix` +only support the :n:`struct` option, while :n:`wf` and :n:`measure` are only supported in +commands such as :cmd:`Function` and :cmd:`Program Fixpoint`. + .. insertprodn term_cofix cofix_body .. prodn:: @@ -646,7 +644,7 @@ The Vernacular The top-level input to |Coq| is a series of :production:`command`\s and :production:`tactic`\s, each terminated with a period and optionally decorated with :ref:`gallina-attributes`. :n:`@ltac_expr` syntax supports both simple -and compound tactics. For example: ``split.`` is a simple tactic while ``split; auto.`` combines two +and compound tactics. For example: ``split`` is a simple tactic while ``split; auto`` combines two simple tactics. Tactics specify how to transform the current proof state as a step in creating a proof. They @@ -706,6 +704,8 @@ has type :n:`@type`. is closed, the :n:`@ident`\(s) become undefined and every object depending on them will be explicitly parameterized (i.e., the variables are *discharged*). See Section :ref:`section-mechanism`. + The :n:`Inline` clause is only relevant inside functors. See :cmd:`Module`. + .. example:: Simple assumptions .. coqtop:: reset in @@ -767,8 +767,12 @@ Section :ref:`typing-rules`. If :n:`@reduce` is present then :n:`@ident` is bound to the result of the specified computation on :n:`@term`. - If :n:`@term` is omitted, Coq enters the proof editing mode. This can be - used to define a term incrementally, in particular by relying on the :tacn:`refine` tactic. + These commands also support the :attr:`universes(polymorphic)`, + :attr:`universes(monomorphic)`, :attr:`program` and + :attr:`canonical` attributes. + + If :n:`@term` is omitted, :n:`@type` is required and Coq enters proof editing mode. + This can be used to define a term incrementally, in particular by relying on the :tacn:`refine` tactic. In this case, the proof should be terminated with :cmd:`Defined` in order to define a constant for which the computational behavior is relevant. See :ref:`proof-editing-mode`. @@ -795,17 +799,13 @@ Inductive types .. cmd:: Inductive @inductive_definition {* with @inductive_definition } - .. insertprodn inductive_definition field_body + .. insertprodn inductive_definition constructor .. prodn:: inductive_definition ::= {? > } @ident_decl {* @binder } {? %| {* @binder } } {? : @type } {? := {? @constructors_or_record } } {? @decl_notations } constructors_or_record ::= {? %| } {+| @constructor } - | {? @ident } %{ {+; @record_field } %} + | {? @ident } %{ {*; @record_field } %} constructor ::= @ident {* @binder } {? @of_type } - record_field ::= {* #[ {*, @attr } ] } @name {? @field_body } {? %| @num } {? @decl_notations } - field_body ::= {* @binder } @of_type - | {* @binder } @of_type := @term - | {* @binder } := @term This command defines one or more inductive types and its constructors. Coq generates destructors @@ -821,9 +821,11 @@ Inductive types may be impossible to derive (for example, when :n:`@ident` is a proposition). - This command supports the :attr:`universes(polymorphic)`, :attr:`universes(monomorphic)`, - :attr:`universes(template)`, :attr:`universes(notemplate)`, - :attr:`Cumulative`, :attr:`NonCumulative` and :attr:`Private` attributes. + This command supports the :attr:`universes(polymorphic)`, + :attr:`universes(monomorphic)`, :attr:`universes(template)`, + :attr:`universes(notemplate)`, :attr:`universes(cumulative)`, + :attr:`universes(noncumulative)` and :attr:`private(matching)` + attributes. Mutually inductive types can be defined by including multiple :n:`@inductive_definition`\s. The :n:`@ident`\s are simultaneously added to the environment before the types of constructors are checked. @@ -851,16 +853,16 @@ Inductive types :n:`@ident` being defined (or :n:`@ident` applied to arguments in the case of annotated inductive types — cf. next section). -The following subsections show examples of simple inductive types, simple annotated -inductive types, simple parametric inductive types and mutually inductive -types. +The following subsections show examples of simple inductive types, +simple annotated inductive types, simple parametric inductive types, +mutually inductive types and private (matching) inductive types. .. _simple-inductive-types: Simple inductive types ~~~~~~~~~~~~~~~~~~~~~~ -A simple inductive type belongs to a universe that is a simple :n:`sort`. +A simple inductive type belongs to a universe that is a simple :n:`@sort`. .. example:: @@ -1122,19 +1124,51 @@ Mutually defined inductive types A generic command :cmd:`Scheme` is useful to build automatically various mutual induction principles. +Private (matching) inductive types +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +.. attr:: private(matching) + + This attribute can be used to forbid the use of the :g:`match` + construct on objects of this inductive type outside of the module + where it is defined. There is also a legacy syntax using the + ``Private`` prefix (cf. :n:`@legacy_attr`). + + The main use case of private (matching) inductive types is to emulate + quotient types / higher-order inductive types in projects such as + the `HoTT library <https://github.com/HoTT/HoTT>`_. + +.. example:: + + .. coqtop:: all + + Module Foo. + #[ private(matching) ] Inductive my_nat := my_O : my_nat | my_S : my_nat -> my_nat. + Check (fun x : my_nat => match x with my_O => true | my_S _ => false end). + End Foo. + Import Foo. + Fail Check (fun x : my_nat => match x with my_O => true | my_S _ => false end). + Variants ~~~~~~~~ -.. cmd:: Variant @inductive_definition {* with @inductive_definition } +.. cmd:: Variant @variant_definition {* with @variant_definition } + + .. insertprodn variant_definition variant_definition + + .. prodn:: + variant_definition ::= @ident_decl {* @binder } {? %| {* @binder } } {? : @type } := {? %| } {+| @constructor } {? @decl_notations } - The :cmd:`Variant` command is identical to the :cmd:`Inductive` command, except + The :cmd:`Variant` command is similar to the :cmd:`Inductive` command, except that it disallows recursive definition of types (for instance, lists cannot be defined using :cmd:`Variant`). No induction scheme is generated for this variant, unless the :flag:`Nonrecursive Elimination Schemes` flag is on. - This command supports the :attr:`universes(polymorphic)`, :attr:`universes(monomorphic)`, - :attr:`universes(template)`, :attr:`universes(notemplate)`, - :attr:`Cumulative`, :attr:`NonCumulative` and :attr:`Private` attributes. + This command supports the :attr:`universes(polymorphic)`, + :attr:`universes(monomorphic)`, :attr:`universes(template)`, + :attr:`universes(notemplate)`, :attr:`universes(cumulative)`, + :attr:`universes(noncumulative)` and :attr:`private(matching)` + attributes. .. exn:: The @num th argument of @ident must be @ident in @type. :undocumented: @@ -1160,9 +1194,11 @@ of the type. type, since such principles only make sense for inductive types. For co-inductive types, the only elimination principle is case analysis. - This command supports the :attr:`universes(polymorphic)`, :attr:`universes(monomorphic)`, - :attr:`universes(template)`, :attr:`universes(notemplate)`, - :attr:`Cumulative`, :attr:`NonCumulative` and :attr:`Private` attributes. + This command supports the :attr:`universes(polymorphic)`, + :attr:`universes(monomorphic)`, :attr:`universes(template)`, + :attr:`universes(notemplate)`, :attr:`universes(cumulative)`, + :attr:`universes(noncumulative)` and :attr:`private(matching)` + attributes. .. example:: @@ -1284,7 +1320,7 @@ constructions. consequently :n:`forall {* @binder }, @type` and its value is equivalent to :n:`fun {* @binder } => @term`. - To be accepted, a :cmd:`Fixpoint` definition has to satisfy some syntactical + To be accepted, a :cmd:`Fixpoint` definition has to satisfy syntactical constraints on a special argument called the decreasing argument. They are needed to ensure that the :cmd:`Fixpoint` definition always terminates. The point of the :n:`{struct @ident}` annotation (see :n:`@fixannot`) is to @@ -1294,11 +1330,14 @@ constructions. system successively tries arguments from left to right until it finds one that satisfies the decreasing condition. + :cmd:`Fixpoint` without the :attr:`program` attribute does not support the + :n:`wf` or :n:`measure` clauses of :n:`@fixannot`. + The :n:`with` clause allows simultaneously defining several mutual fixpoints. It is especially useful when defining functions over mutually defined inductive types. Example: :ref:`Mutual Fixpoints<example_mutual_fixpoints>`. - If :n:`@term` is omitted, :n:`@type` is required and Coq enters the proof editing mode. + If :n:`@term` is omitted, :n:`@type` is required and Coq enters proof editing mode. This can be used to define a term incrementally, in particular by relying on the :tacn:`refine` tactic. In this case, the proof should be terminated with :cmd:`Defined` in order to define a constant for which the computational behavior is relevant. See :ref:`proof-editing-mode`. @@ -1455,7 +1494,7 @@ Definitions of recursive objects in co-inductive types As in the :cmd:`Fixpoint` command, the :n:`with` clause allows simultaneously defining several mutual cofixpoints. - If :n:`@term` is omitted, :n:`@type` is required and Coq enters the proof editing mode. + If :n:`@term` is omitted, :n:`@type` is required and Coq enters proof editing mode. This can be used to define a term incrementally, in particular by relying on the :tacn:`refine` tactic. In this case, the proof should be terminated with :cmd:`Defined` in order to define a constant for which the computational behavior is relevant. See :ref:`proof-editing-mode`. @@ -1483,9 +1522,6 @@ Computations | pattern {+, @pattern_occ } | @ident delta_flag ::= {? - } [ {+ @smart_qualid } ] - smart_qualid ::= @qualid - | @by_notation - by_notation ::= @string {? % @ident } strategy_flag ::= {+ @red_flags } | @delta_flag red_flags ::= beta @@ -1497,10 +1533,8 @@ Computations | delta {? @delta_flag } ref_or_pattern_occ ::= @smart_qualid {? at @occs_nums } | @one_term {? at @occs_nums } - occs_nums ::= {+ @num_or_var } - | - @num_or_var {* @int_or_var } - num_or_var ::= @num - | @ident + occs_nums ::= {+ {| @num | @ident } } + | - {| @num | @ident } {* @int_or_var } int_or_var ::= @int | @ident unfold_occ ::= @smart_qualid {? at @occs_nums } @@ -1607,14 +1641,18 @@ the proof and adds it to the environment. Attributes ----------- -.. insertprodn all_attrs legacy_attrs +.. insertprodn all_attrs legacy_attr .. prodn:: - all_attrs ::= {* #[ {*, @attr } ] } {? @legacy_attrs } + all_attrs ::= {* #[ {*, @attr } ] } {* @legacy_attr } attr ::= @ident {? @attr_value } attr_value ::= = @string | ( {*, @attr } ) - legacy_attrs ::= {? {| Local | Global } } {? {| Polymorphic | Monomorphic } } {? Program } {? {| Cumulative | NonCumulative } } {? Private } + legacy_attr ::= {| Local | Global } + | {| Polymorphic | Monomorphic } + | {| Cumulative | NonCumulative } + | Private + | Program Attributes modify the behavior of a command or tactic. Syntactically, most commands and tactics can be decorated with attributes, but @@ -1623,7 +1661,7 @@ attributes not supported by the command or tactic will be flagged as errors. The order of top-level attributes doesn't affect their meaning. ``#[foo,bar]``, ``#[bar,foo]``, ``#[foo]#[bar]`` and ``#[bar]#[foo]`` are equivalent. -The legacy attributes (:n:`@legacy_attrs`) provide an older, alternate syntax +The legacy attributes (:n:`@legacy_attr`) provide an older, alternate syntax for certain attributes. They are equivalent to new attributes as follows: ================ ================================ @@ -1633,65 +1671,12 @@ Legacy attribute New attribute `Global` :attr:`global` `Polymorphic` :attr:`universes(polymorphic)` `Monomorphic` :attr:`universes(monomorphic)` -`Cumulative` none -`NonCumulative` none -`Private` none +`Cumulative` :attr:`universes(cumulative)` +`NonCumulative` :attr:`universes(noncumulative)` +`Private` :attr:`private(matching)` `Program` :attr:`program` ================ ================================ -Some attributes are specific to a command, and so are described with -that command. Currently, the following attributes are recognized: - -.. attr:: universes(monomorphic) - :name: universes(monomorphic) - - See :ref:`polymorphicuniverses`. - -.. attr:: universes(polymorphic) - :name: universes(polymorphic) - - See :ref:`polymorphicuniverses`. - -.. attr:: universes(template) - :name: universes(template) - - See :ref:`Template-polymorphism` - -.. attr:: universes(notemplate) - :name: universes(notemplate) - - See :ref:`Template-polymorphism` - -.. attr:: program - - See :ref:`programs`. - -.. attr:: global - - See :ref:`controlling-locality-of-commands`. - -.. attr:: local - - See :ref:`controlling-locality-of-commands`. - -.. attr:: Cumulative - - Legacy attribute, only allowed in a polymorphic context. - Specifies that two instances of the same inductive type (family) are convertible - based on the universe variances; they do not need to be equal. - See :ref:`cumulative`. - -.. attr:: NonCumulative - - Legacy attribute, only allowed in a polymorphic context. - Specifies that two instances of the same inductive type (family) are convertible - only if all the universes are equal. - See :ref:`cumulative`. - -.. attr:: Private - - Legacy attribute. Documentation to be added. - .. attr:: deprecated ( {? since = @string , } {? note = @string } ) :name: deprecated @@ -1703,46 +1688,24 @@ that command. Currently, the following attributes are recognized: It can trigger the following warnings: - .. warn:: Tactic @qualid is deprecated since @string. @string. - :undocumented: - - .. warn:: Tactic Notation @qualid is deprecated since @string. @string. - :undocumented: - - .. warn:: Notation @string__1 is deprecated since @string__2. @string__3. - - :n:`@string__1` is the actual notation, :n:`@string__2` is the version number, - :n:`@string__3` is the note. + .. warn:: Tactic @qualid is deprecated since @string__since. @string__note. + Tactic Notation @qualid is deprecated since @string__since. @string__note. + Notation @string is deprecated since @string__since. @string__note. -.. attr:: canonical - - This attribute can decorate a :cmd:`Definition` or :cmd:`Let` command. - It is equivalent to having a :cmd:`Canonical Structure` declaration just - after the command. - - This attribute can take the value ``false`` when decorating a record field - declaration with the effect of preventing the field from being involved in - the inference of canonical instances. - - See also :ref:`canonical-structure-declaration`. - -.. example:: + :n:`@qualid` or :n:`@string` is the notation, :n:`@string__since` is the version number, + :n:`@string__note` is the note (usually explains the replacement). - .. coqtop:: all reset warn + .. example:: - From Coq Require Program. - #[program] Definition one : nat := S _. - Next Obligation. - exact O. - Defined. + .. coqtop:: all reset warn - #[deprecated(since="8.9.0", note="Use idtac instead.")] - Ltac foo := idtac. + #[deprecated(since="8.9.0", note="Use idtac instead.")] + Ltac foo := idtac. - Goal True. - Proof. + Goal True. + Proof. now foo. - Abort. + Abort. .. warn:: Unsupported attribute diff --git a/doc/sphinx/license.rst b/doc/sphinx/license.rst index 55c6d988f0..35837f8407 100644 --- a/doc/sphinx/license.rst +++ b/doc/sphinx/license.rst @@ -1,7 +1,7 @@ -License -------- +.. note:: **License** -This material (the Coq Reference Manual) may be distributed only subject to the -terms and conditions set forth in the Open Publication License, v1.0 or later -(the latest version is presently available at -http://www.opencontent.org/openpub). Options A and B are not elected. + This material (the Coq Reference Manual) may be distributed only + subject to the terms and conditions set forth in the Open + Publication License, v1.0 or later (the latest version is presently + available at http://www.opencontent.org/openpub). Options A and B + are not elected. diff --git a/doc/sphinx/practical-tools/coq-commands.rst b/doc/sphinx/practical-tools/coq-commands.rst index 98d222e317..aa4b6edd7d 100644 --- a/doc/sphinx/practical-tools/coq-commands.rst +++ b/doc/sphinx/practical-tools/coq-commands.rst @@ -227,7 +227,10 @@ and ``coqtop``, unless stated otherwise: type of the option. For flags ``Option Name`` is equivalent to ``Option Name=true``. For instance ``-set "Universe Polymorphism"`` will enable :flag:`Universe Polymorphism`. Note that the quotes are - shell syntax, Coq does not see them. + shell syntax, Coq does not see them. Flags are processed after initialization + of the document. This includes the `Prelude` if loaded and any libraries loaded + through the `-l`, `-lv`, `-r`, `-re`, `-ri`, `rfrom`, `-refrom` and `-rifrom` + options. :-unset *string*: As ``-set`` but used to disable options and flags. :-compat *version*: Attempt to maintain some backward-compatibility with a previous version. diff --git a/doc/sphinx/practical-tools/utilities.rst b/doc/sphinx/practical-tools/utilities.rst index 514353e39b..d61e5ddce7 100644 --- a/doc/sphinx/practical-tools/utilities.rst +++ b/doc/sphinx/practical-tools/utilities.rst @@ -499,6 +499,40 @@ To build, say, two targets foo.vo and bar.vo in parallel one can use (``.PHONY`` or not) please use ``CoqMakefile.local``. +Precompiling for ``native_compute`` ++++++++++++++++++++++++++++++++++++ + +To compile files for ``native_compute``, one can use the +``-native-compiler yes`` option of |Coq|, for instance by putting the +following in a :ref:`coqmakefilelocal` file: + +:: + + COQEXTRAFLAGS += -native-compiler yes + +The generated ``CoqMakefile`` installation target will then take care +of installing the extra ``.coq-native`` directories. + +.. note:: + + As an alternative to modifying any file, one can set the + environment variable when calling ``make``: + + :: + + COQEXTRAFLAGS="-native-compiler yes" make + + This can be useful when files cannot be modified, for instance when + installing via OPAM a package built with ``coq_makefile``: + + :: + + COQEXTRAFLAGS="-native-compiler yes" opam install coq-package + +.. note:: + + This requires all dependencies to be themselves compiled with + ``-native-compiler yes``. Building a |Coq| project with Dune ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -603,470 +637,6 @@ See the man page of ``coqdep`` for more details and options. Both Dune and ``coq_makefile`` use ``coqdep`` to compute the dependencies among the files part of a Coq project. -.. _coqdoc: - -Documenting |Coq| files with coqdoc ------------------------------------ - -coqdoc is a documentation tool for the proof assistant |Coq|, similar to -``javadoc`` or ``ocamldoc``. The task of coqdoc is - - -#. to produce a nice |Latex| and/or HTML document from |Coq| source files, - readable for a human and not only for the proof assistant; -#. to help the user navigate his own (or third-party) sources. - - - -Principles -~~~~~~~~~~ - -Documentation is inserted into |Coq| files as *special comments*. Thus -your files will compile as usual, whether you use coqdoc or not. coqdoc -presupposes that the given |Coq| files are well-formed (at least -lexically). Documentation starts with ``(**``, followed by a space, and -ends with ``*)``. The documentation format is inspired by Todd -A. Coram’s *Almost Free Text (AFT)* tool: it is mainly ``ASCII`` text with -some syntax-light controls, described below. coqdoc is robust: it -shouldn’t fail, whatever the input is. But remember: “garbage in, -garbage out”. - - -|Coq| material inside documentation. -++++++++++++++++++++++++++++++++++++ - -|Coq| material is quoted between the delimiters ``[`` and ``]``. Square brackets -may be nested, the inner ones being understood as being part of the -quoted code (thus you can quote a term like ``fun x => u`` by writing ``[fun -x => u]``). Inside quotations, the code is pretty-printed in the same -way as it is in code parts. - -Preformatted vernacular is enclosed by ``[[`` and ``]]``. The former must be -followed by a newline and the latter must follow a newline. - - -Pretty-printing. -++++++++++++++++ - -coqdoc uses different faces for identifiers and keywords. The pretty- -printing of |Coq| tokens (identifiers or symbols) can be controlled -using one of the following commands: - -:: - - - (** printing *token* %...LATEX...% #...html...# *) - - -or - -:: - - - (** printing *token* $...LATEX math...$ #...html...# *) - - -It gives the |Latex| and HTML texts to be produced for the given |Coq| -token. Either the |Latex| or the HTML rule may be omitted, causing the -default pretty-printing to be used for this token. - -The printing for one token can be removed with - -:: - - - (** remove printing *token* *) - - -Initially, the pretty-printing table contains the following mapping: - -===== === ==== ===== === ==== ==== === -`->` → `<-` ← `*` × -`<=` ≤ `>=` ≥ `=>` ⇒ -`<>` ≠ `<->` ↔ `|-` ⊢ -`\\/` ∨ `/\\` ∧ `~` ¬ -===== === ==== ===== === ==== ==== === - -Any of these can be overwritten or suppressed using the printing -commands. - -.. note:: - - The recognition of tokens is done by a (``ocaml``) lex - automaton and thus applies the longest-match rule. For instance, `->~` - is recognized as a single token, where |Coq| sees two tokens. It is the - responsibility of the user to insert space between tokens *or* to give - pretty-printing rules for the possible combinations, e.g. - - :: - - (** printing ->~ %\ensuremath{\rightarrow\lnot}% *) - - - -Sections -++++++++ - -Sections are introduced by 1 to 4 asterisks at the beginning of a line -followed by a space and the title of the section. One asterisk is a section, -two a subsection, etc. - -.. example:: - - :: - - (** * Well-founded relations - - In this section, we introduce... *) - - -Lists. -++++++ - -List items are introduced by a leading dash. coqdoc uses whitespace to -determine the depth of a new list item and which text belongs in which -list items. A list ends when a line of text starts at or before the -level of indenting of the list’s dash. A list item’s dash must always -be the first non-space character on its line (so, in particular, a -list can not begin on the first line of a comment - start it on the -second line instead). - -.. example:: - - :: - - We go by induction on [n]: - - If [n] is 0... - - If [n] is [S n'] we require... - - two paragraphs of reasoning, and two subcases: - - - In the first case... - - In the second case... - - So the theorem holds. - - - -Rules. -++++++ - -More than 4 leading dashes produce a horizontal rule. - - -Emphasis. -+++++++++ - -Text can be italicized by enclosing it in underscores. A non-identifier -character must precede the leading underscore and follow the trailing -underscore, so that uses of underscores in names aren’t mistaken for -emphasis. Usually, these are spaces or punctuation. - -:: - - This sentence contains some _emphasized text_. - - - -Escaping to |Latex| and HTML. -+++++++++++++++++++++++++++++++ - -Pure |Latex| or HTML material can be inserted using the following -escape sequences: - - -+ ``$...LATEX stuff...$`` inserts some |Latex| material in math mode. - Simply discarded in HTML output. -+ ``%...LATEX stuff...%`` inserts some |Latex| material. Simply - discarded in HTML output. -+ ``#...HTML stuff...#`` inserts some HTML material. Simply discarded in - |Latex| output. - -.. note:: - to simply output the characters ``$``, ``%`` and ``#`` and escaping - their escaping role, these characters must be doubled. - - -Verbatim -++++++++ - -Verbatim material is introduced by a leading ``<<`` and closed by ``>>`` -at the beginning of a line. - -.. example:: - - :: - - Here is the corresponding caml code: - << - let rec fact n = - if n <= 1 then 1 else n * fact (n-1) - >> - - - -Hyperlinks -++++++++++ - -Hyperlinks can be inserted into the HTML output, so that any -identifier is linked to the place of its definition. - -``coqc file.v`` automatically dumps localization information in -``file.glob`` or appends it to a file specified using the option ``--dump-glob -file``. Take care of erasing this global file, if any, when starting -the whole compilation process. - -Then invoke coqdoc or ``coqdoc --glob-from file`` to tell coqdoc to look -for name resolutions in the file ``file`` (it will look in ``file.glob`` -by default). - -Identifiers from the |Coq| standard library are linked to the Coq website -`<http://coq.inria.fr/library/>`_. This behavior can be changed -using command line options ``--no-externals`` and ``--coqlib``; see below. - - -Hiding / Showing parts of the source. -+++++++++++++++++++++++++++++++++++++ - -Some parts of the source can be hidden using command line options ``-g`` -and ``-l`` (see below), or using such comments: - -:: - - - (* begin hide *) - *some Coq material* - (* end hide *) - - -Conversely, some parts of the source which would be hidden can be -shown using such comments: - -:: - - - (* begin show *) - *some Coq material* - (* end show *) - - -The latter cannot be used around some inner parts of a proof, but can -be used around a whole proof. - - -Usage -~~~~~ - -coqdoc is invoked on a shell command line as follows: -``coqdoc <options and files>``. -Any command line argument which is not an option is considered to be a -file (even if it starts with a ``-``). |Coq| files are identified by the -suffixes ``.v`` and ``.g`` and |Latex| files by the suffix ``.tex``. - - -:HTML output: This is the default output format. One HTML file is created for - each |Coq| file given on the command line, together with a file - ``index.html`` (unless ``option-no-index is passed``). The HTML pages use a - style sheet named ``style.css``. Such a file is distributed with coqdoc. -:|Latex| output: A single |Latex| file is created, on standard - output. It can be redirected to a file using the option ``-o``. The order of - files on the command line is kept in the final document. |Latex| - files given on the command line are copied ‘as is’ in the final - document . DVI and PostScript can be produced directly with the - options ``-dvi`` and ``-ps`` respectively. -:TEXmacs output: To translate the input files to TEXmacs format, - to be used by the TEXmacs |Coq| interface. - - - -Command line options -++++++++++++++++++++ - - -**Overall options** - - - :--HTML: Select a HTML output. - :--|Latex|: Select a |Latex| output. - :--dvi: Select a DVI output. - :--ps: Select a PostScript output. - :--texmacs: Select a TEXmacs output. - :--stdout: Write output to stdout. - :-o file, --output file: Redirect the output into the file ‘file’ - (meaningless with ``-html``). - :-d dir, --directory dir: Output files into directory ‘dir’ instead of - the current directory (option ``-d`` does not change the filename specified - with the option ``-o``, if any). - :--body-only: Suppress the header and trailer of the final document. - Thus, you can insert the resulting document into a larger one. - :-p string, --preamble string: Insert some material in the |Latex| - preamble, right before ``\begin{document}`` (meaningless with ``-html``). - :--vernac-file file,--tex-file file: Considers the file ‘file’ - respectively as a ``.v`` (or ``.g``) file or a ``.tex`` file. - :--files-from file: Read filenames to be processed from the file ‘file’ as if - they were given on the command line. Useful for program sources split - up into several directories. - :-q, --quiet: Be quiet. Do not print anything except errors. - :-h, --help: Give a short summary of the options and exit. - :-v, --version: Print the version and exit. - - - -**Index options** - - The default behavior is to build an index, for the HTML output only, - into ``index.html``. - - :--no-index: Do not output the index. - :--multi-index: Generate one page for each category and each letter in - the index, together with a top page ``index.html``. - :--index string: Make the filename of the index string instead of - “index”. Useful since “index.html” is special. - - - -**Table of contents option** - - :-toc, --table-of-contents: Insert a table of contents. For a |Latex| - output, it inserts a ``\tableofcontents`` at the beginning of the - document. For a HTML output, it builds a table of contents into - ``toc.html``. - :--toc-depth int: Only include headers up to depth ``int`` in the table of - contents. - - -**Hyperlink options** - - :--glob-from file: Make references using |Coq| globalizations from file - file. (Such globalizations are obtained with Coq option ``-dump-glob``). - :--no-externals: Do not insert links to the |Coq| standard library. - :--external url coqdir: Use given URL for linking references whose - name starts with prefix ``coqdir``. - :--coqlib url: Set base URL for the Coq standard library (default is - `<http://coq.inria.fr/library/>`_). This is equivalent to ``--external url - Coq``. - :-R dir coqdir: Recursively map physical directory dir to |Coq| logical - directory ``coqdir`` (similarly to |Coq| option ``-R``). - :-Q dir coqdir: Map physical directory dir to |Coq| logical - directory ``coqdir`` (similarly to |Coq| option ``-Q``). - - .. note:: - - options ``-R`` and ``-Q`` only have - effect on the files *following* them on the command line, so you will - probably need to put this option first. - - -**Title options** - - :-s , --short: Do not insert titles for the files. The default - behavior is to insert a title like “Library Foo” for each file. - :--lib-name string: Print “string Foo” instead of “Library Foo” in - titles. For example “Chapter” and “Module” are reasonable choices. - :--no-lib-name: Print just “Foo” instead of “Library Foo” in titles. - :--lib-subtitles: Look for library subtitles. When enabled, the - beginning of each file is checked for a comment of the form: - - :: - - (** * ModuleName : text *) - - where ``ModuleName`` must be the name of the file. If it is present, the - text is used as a subtitle for the module in appropriate places. - :-t string, --title string: Set the document title. - - -**Contents options** - - :-g, --gallina: Do not print proofs. - :-l, --light: Light mode. Suppress proofs (as with ``-g``) and the following commands: - - + [Recursive] Tactic Definition - + Hint / Hints - + Require - + Transparent / Opaque - + Implicit Argument / Implicits - + Section / Variable / Hypothesis / End - - - - The behavior of options ``-g`` and ``-l`` can be locally overridden using the - ``(* begin show *) … (* end show *)`` environment (see above). - - There are a few options that control the parsing of comments: - - :--parse-comments: Parse regular comments delimited by ``(*`` and ``*)`` as - well. They are typeset inline. - :--plain-comments: Do not interpret comments, simply copy them as - plain-text. - :--interpolate: Use the globalization information to typeset - identifiers appearing in |Coq| escapings inside comments. - -**Language options** - - - The default behavior is to assume ASCII 7 bit input files. - - :-latin1, --latin1: Select ISO-8859-1 input files. It is equivalent to - --inputenc latin1 --charset iso-8859-1. - :-utf8, --utf8: Set --inputenc utf8x for |Latex| output and--charset - utf-8 for HTML output. Also use Unicode replacements for a couple of - standard plain ASCII notations such as → for ``->`` and ∀ for ``forall``. |Latex| - UTF-8 support can be found - at `<http://www.ctan.org/pkg/unicode>`_. For the interpretation of Unicode - characters by |Latex|, extra packages which coqdoc does not provide - by default might be required, such as textgreek for some Greek letters - or ``stmaryrd`` for some mathematical symbols. If a Unicode character is - missing an interpretation in the utf8x input encoding, add - ``\DeclareUnicodeCharacter{code}{LATEX-interpretation}``. Packages - and declarations can be added with option ``-p``. - :--inputenc string: Give a |Latex| input encoding, as an option to |Latex| - package ``inputenc``. - :--charset string: Specify the HTML character set, to be inserted in - the HTML header. - - - -The coqdoc |Latex| style file -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -In case you choose to produce a document without the default |Latex| -preamble (by using option ``--no-preamble``), then you must insert into -your own preamble the command - -:: - - \usepackage{coqdoc} - -The package optionally takes the argument ``[color]`` to typeset -identifiers with colors (this requires the ``xcolor`` package). - -Then you may alter the rendering of the document by redefining some -macros: - -:coqdockw, coqdocid, …: The one-argument macros for typesetting - keywords and identifiers. Defaults are sans-serif for keywords and - italic for identifiers.For example, if you would like a slanted font - for keywords, you may insert - - :: - - \renewcommand{\coqdockw}[1]{\textsl{#1}} - - - anywhere between ``\usepackage{coqdoc}`` and ``\begin{document}``. - - -:coqdocmodule: - One-argument macro for typesetting the title of a ``.v`` - file. Default is - - :: - - \newcommand{\coqdocmodule}[1]{\section*{Module #1}} - - and you may redefine it using ``\renewcommand``. - Embedded Coq phrases inside |Latex| documents --------------------------------------------- diff --git a/doc/sphinx/proof-engine/tactics.rst b/doc/sphinx/proof-engine/tactics.rst index be185e885b..19573eee43 100644 --- a/doc/sphinx/proof-engine/tactics.rst +++ b/doc/sphinx/proof-engine/tactics.rst @@ -3222,7 +3222,7 @@ the conversion in hypotheses :n:`{+ @ident}`. + A constant can be marked to be unfolded only if applied to enough arguments. The number of arguments required can be specified using the - ``/`` symbol in the argument list of the :cmd:`Arguments <Arguments (implicits)>` vernacular command. + ``/`` symbol in the argument list of the :cmd:`Arguments` command. .. example:: @@ -4286,7 +4286,7 @@ some incompatibilities. :name: Firstorder Solver The default tactic used by :tacn:`firstorder` when no rule applies is - :g:`auto with *`, it can be reset locally or globally using this option. + :g:`auto with core`, it can be reset locally or globally using this option. .. cmd:: Print Firstorder Solver diff --git a/doc/sphinx/proof-engine/vernacular-commands.rst b/doc/sphinx/proof-engine/vernacular-commands.rst index 4401f8fa2f..b22c5286fe 100644 --- a/doc/sphinx/proof-engine/vernacular-commands.rst +++ b/doc/sphinx/proof-engine/vernacular-commands.rst @@ -91,34 +91,30 @@ and tables: Flags, options and tables are identified by a series of identifiers, each with an initial capital letter. -.. cmd:: {? {| Local | Global | Export } } Set @flag +.. cmd:: Set @flag :name: Set - Sets :token:`flag` on. Scoping qualifiers are - described :ref:`here <set_unset_scope_qualifiers>`. + Sets :token:`flag` on. -.. cmd:: {? {| Local | Global | Export } } Unset @flag +.. cmd:: Unset @flag :name: Unset - Sets :token:`flag` off. Scoping qualifiers are - described :ref:`here <set_unset_scope_qualifiers>`. + Sets :token:`flag` off. .. cmd:: Test @flag Prints the current value of :token:`flag`. -.. cmd:: {? {| Local | Global | Export } } Set @option {| @num | @string } +.. cmd:: Set @option {| @num | @string } :name: Set @option - Sets :token:`option` to the specified value. Scoping qualifiers are - described :ref:`here <set_unset_scope_qualifiers>`. + Sets :token:`option` to the specified value. -.. cmd:: {? {| Local | Global | Export } } Unset @option +.. cmd:: Unset @option :name: Unset @option - Sets :token:`option` to its default value. Scoping qualifiers are - described :ref:`here <set_unset_scope_qualifiers>`. + Sets :token:`option` to its default value. .. cmd:: Test @option @@ -157,27 +153,37 @@ capital letter. A synonym for :cmd:`Print Options`. -.. _set_unset_scope_qualifiers: +Locality attributes supported by :cmd:`Set` and :cmd:`Unset` +```````````````````````````````````````````````````````````` + +The :cmd:`Set` and :cmd:`Unset` commands support the :attr:`local`, +:attr:`global` and :attr:`export` locality attributes: + +* no attribute: the original setting is *not* restored at the end of + the current module or section. +* :attr:`local` (an alternative syntax is to use the ``Local`` + prefix): the setting is applied within the current module or + section. The original value of the setting is restored at the end + of the current module or section. +* :attr:`export` (an alternative syntax is to use the ``Export`` + prefix): similar to :attr:`local`, the original value of the setting + is restored at the end of the current module or section. In + addition, if the value is set in a module, then :cmd:`Import`\-ing + the module sets the option or flag. +* :attr:`global` (an alternative syntax is to use the ``Global`` + prefix): the original setting is *not* restored at the end of the + current module or section. In addition, if the value is set in a + file, then :cmd:`Require`\-ing the file sets the option. + +Newly opened modules and sections inherit the current settings. -Scope qualifiers for :cmd:`Set` and :cmd:`Unset` -````````````````````````````````````````````````` - -:n:`{? {| Local | Global | Export } }` - -Flag and option settings can be global in scope or local to nested scopes created by -:cmd:`Module` and :cmd:`Section` commands. There are four alternatives: - -* no qualifier: the original setting is *not* restored at the end of the current module or section. -* **Local**: the setting is applied within the current scope. The original value of the option - or flag is restored at the end of the current module or section. -* **Global**: similar to no qualifier, the original setting is *not* restored at the end of the current - module or section. In addition, if the value is set in a file, then :cmd:`Require`-ing - the file sets the option. -* **Export**: similar to **Local**, the original value of the option or flag is restored at the - end of the current module or section. In addition, if the value is set in a file, then :cmd:`Import`-ing - the file sets the option. +.. note:: -Newly opened scopes inherit the current settings. + The use of the :attr:`global` attribute with the :cmd:`Set` and + :cmd:`Unset` commands is discouraged. If your goal is to define + project-wide settings, you should rather use the command-line + arguments ``-set`` and ``-unset`` for setting flags and options + (cf. :ref:`command-line-options`). .. _requests-to-the-environment: @@ -315,18 +321,6 @@ Requests to the environment Search (?x * _ + ?x * _)%Z outside OmegaLemmas. - .. cmdv:: SearchAbout - :name: SearchAbout - - .. deprecated:: 8.5 - - Up to |Coq| version 8.4, :cmd:`Search` had the behavior of current - :cmd:`SearchHead` and the behavior of current :cmd:`Search` was obtained with - command :cmd:`SearchAbout`. For compatibility, the deprecated name - :cmd:`SearchAbout` can still be used as a synonym of :cmd:`Search`. For - compatibility, the list of objects to search when using :cmd:`SearchAbout` - may also be enclosed by optional ``[ ]`` delimiters. - .. cmd:: SearchHead @term @@ -602,11 +596,11 @@ file is a particular case of module called *library file*. This loads and declares the module :n:`@qualid` and its dependencies then imports the contents of :n:`@qualid` as described - :ref:`here <import_qualid>`. It does not import the modules on which - qualid depends unless these modules were themselves required in module + for :cmd:`Import`. It does not import the modules that + :n:`@qualid` depends on unless these modules were themselves required in module :n:`@qualid` - using :cmd:`Require Export`, as described below, or recursively required - through a sequence of :cmd:`Require Export`. If the module required has + using :cmd:`Require Export`, or recursively required + through a series of :cmd:`Require Export`. If the module required has already been loaded, :cmd:`Require Import` :n:`@qualid` simply imports it, as :cmd:`Import` :n:`@qualid` would. @@ -665,13 +659,9 @@ file is a particular case of module called *library file*. the time it was compiled. - .. exn:: Require is not allowed inside a module or a module type. + .. warn:: Require inside a module is deprecated and strongly discouraged. You can Require a module at toplevel and optionally Import it inside another one. - This command - is not allowed inside a module or a module type being defined. It is - meant to describe a dependency between compilation units. Note however - that the commands ``Import`` and ``Export`` alone can be used inside modules - (see Section :ref:`Import <import_qualid>`). + Note that the :cmd:`Import` and :cmd:`Export` commands can be used inside modules. .. seealso:: Chapter :ref:`thecoqcommands` @@ -927,16 +917,17 @@ Quitting and debugging .. cmd:: Fail @command - For debugging scripts, sometimes it is desirable to know - whether a command or a tactic fails. If the given :n:`@command` - fails, the ``Fail`` statement succeeds, without changing the proof - state, and in interactive mode, the system - prints a message confirming the failure. - If the given :n:`@command` succeeds, the statement is an error, and - it prints a message indicating that the failure did not occur. + For debugging scripts, sometimes it is desirable to know whether a + command or a tactic fails. If the given :n:`@command` fails, then + :n:`Fail @command` succeeds (excepts in the case of + critical errors, like a "stack overflow"), without changing the + proof state, and in interactive mode, the system prints a message + confirming the failure. .. exn:: The command has not failed! - :undocumented: + + If the given :n:`@command` succeeds, then :n:`Fail @command` + fails with this error message. .. _controlling-display: @@ -1152,49 +1143,51 @@ described first. Controlling the locality of commands ----------------------------------------- +.. attr:: global + local -.. cmd:: Local @command - Global @command - - Some commands support a Local or Global prefix modifier to control the - scope of their effect. There are four kinds of commands: - + Some commands support a :attr:`local` or :attr:`global` attribute + to control the scope of their effect. There is also a legacy (and + much more commonly used) syntax using the ``Local`` or ``Global`` + prefixes (see :n:`@legacy_attr`). There are four kinds of + commands: + Commands whose default is to extend their effect both outside the section and the module or library file they occur in. For these - commands, the Local modifier limits the effect of the command to the + commands, the :attr:`local` attribute limits the effect of the command to the current section or module it occurs in. As an example, the :cmd:`Coercion` and :cmd:`Strategy` commands belong to this category. + Commands whose default behavior is to stop their effect at the end of the section they occur in but to extend their effect outside the module or - library file they occur in. For these commands, the Local modifier limits the + library file they occur in. For these commands, the :attr:`local` attribute limits the effect of the command to the current module if the command does not occur in a - section and the Global modifier extends the effect outside the current + section and the :attr:`global` attribute extends the effect outside the current sections and current module if the command occurs in a section. As an example, - the :cmd:`Arguments <Arguments (implicits)>`, :cmd:`Ltac` or :cmd:`Notation` commands belong + the :cmd:`Arguments`, :cmd:`Ltac` or :cmd:`Notation` commands belong to this category. Notice that a subclass of these commands do not support - extension of their scope outside sections at all and the Global modifier is not + extension of their scope outside sections at all and the :attr:`global` attribute is not applicable to them. + Commands whose default behavior is to stop their effect at the end - of the section or module they occur in. For these commands, the ``Global`` - modifier extends their effect outside the sections and modules they - occur in. The :cmd:`Transparent` and :cmd:`Opaque` - (see Section :ref:`vernac-controlling-the-reduction-strategies`) commands + of the section or module they occur in. For these commands, the :attr:`global` + attribute extends their effect outside the sections and modules they + occur in. The :cmd:`Transparent` and :cmd:`Opaque` commands belong to this category. + Commands whose default behavior is to extend their effect outside sections but not outside modules when they occur in a section and to extend their effect outside the module or library file they occur in - when no section contains them. For these commands, the Local modifier - limits the effect to the current section or module while the Global - modifier extends the effect outside the module even when the command + when no section contains them. For these commands, the :attr:`local` attribute + limits the effect to the current section or module while the :attr:`global` + attribute extends the effect outside the module even when the command occurs in a section. The :cmd:`Set` and :cmd:`Unset` commands belong to this category. .. attr:: export - Some commands support an :attr:`export` attribute. The effect of the attribute - is to make the effect of the command available when the module containing it - is imported. The :cmd:`Hint` command accepts it for instance. + Some commands support an :attr:`export` attribute. The effect of + the attribute is to make the effect of the command available when + the module containing it is imported. It is supported in + particular by the :cmd:`Hint`, :cmd:`Set` and :cmd:`Unset` + commands. .. _controlling-typing-flags: diff --git a/doc/sphinx/proofs/automatic-tactics/index.rst b/doc/sphinx/proofs/automatic-tactics/index.rst new file mode 100644 index 0000000000..a219770c69 --- /dev/null +++ b/doc/sphinx/proofs/automatic-tactics/index.rst @@ -0,0 +1,20 @@ +.. _automatic-tactics: + +===================================================== +Built-in decision procedures and programmable tactics +===================================================== + +Some tactics are largely automated and are able to solve complex +goals. This chapter presents both some decision procedures that can +be used to solve some specific categories of goals, and some +programmable tactics, that the user can instrument to handle some +complex goals in new domains. + +.. toctree:: + :maxdepth: 1 + + ../../addendum/omega + ../../addendum/micromega + ../../addendum/ring + ../../addendum/nsatz + ../../addendum/generalized-rewriting diff --git a/doc/sphinx/proofs/creating-tactics/index.rst b/doc/sphinx/proofs/creating-tactics/index.rst new file mode 100644 index 0000000000..1af1b0b726 --- /dev/null +++ b/doc/sphinx/proofs/creating-tactics/index.rst @@ -0,0 +1,34 @@ +.. _writing-tactics: + +==================== +Creating new tactics +==================== + +The languages presented in this chapter allow one to build complex +tactics by combining existing ones with constructs such as +conditionals and looping. While :ref:`Ltac <ltac>` was initially +thought of as a language for doing some basic combinations, it has +been used successfully to build highly complex tactics as well, but +this has also highlighted its limits and fragility. The experimental +language :ref:`Ltac2 <ltac2>` is a typed and more principled variant +which is more adapted to building complex tactics. + +There are other solutions beyond these two tactic languages to write +new tactics: + +- `Mtac2 <https://github.com/Mtac2/Mtac2>`_ is an external plugin + which provides another typed tactic language. While Ltac2 belongs + to the ML language family, Mtac2 reuses the language of Coq itself + as the language to build Coq tactics. + +- The most traditional way of building new complex tactics is to write + a Coq plugin in OCaml. Beware that this also requires much more + effort and commitment. A tutorial for writing Coq plugins is + available in the Coq repository in `doc/plugin_tutorial + <https://github.com/coq/coq/tree/master/doc/plugin_tutorial>`_. + +.. toctree:: + :maxdepth: 1 + + ../../proof-engine/ltac + ../../proof-engine/ltac2 diff --git a/doc/sphinx/proofs/writing-proofs/index.rst b/doc/sphinx/proofs/writing-proofs/index.rst new file mode 100644 index 0000000000..a279a5957f --- /dev/null +++ b/doc/sphinx/proofs/writing-proofs/index.rst @@ -0,0 +1,34 @@ +.. _writing-proofs: + +============== +Writing proofs +============== + +Coq is an interactive theorem prover, or proof assistant, which means +that proofs can be constructed interactively through a dialog between +the user and the assistant. The building blocks for this dialog are +tactics which the user will use to represent steps in the proof of a +theorem. + +Incomplete proofs have one or more open (unproven) sub-goals. Each +goal has its own context (a set of assumptions that can be used to +prove the goal). Tactics can transform goals and contexts. +Internally, the incomplete proof is represented as a partial proof +term, with holes for the unproven sub-goals. + +When a proof is complete, the user leaves the proof mode and defers +the verification of the resulting proof term to the :ref:`kernel +<core-language>`. + +This chapter is divided in several parts, describing the basic ideas +of the proof mode (during which tactics can be used), and several +flavors of tactics, including the SSReflect proof language. + +.. toctree:: + :maxdepth: 1 + + ../../proof-engine/proof-handling + ../../proof-engine/tactics + ../../proof-engine/ssreflect-proof-language + ../../proof-engine/detailed-tactic-examples + ../../user-extensions/proof-schemes diff --git a/doc/sphinx/refman-preamble.rst b/doc/sphinx/refman-preamble.rst index de95eda989..05e665a43b 100644 --- a/doc/sphinx/refman-preamble.rst +++ b/doc/sphinx/refman-preamble.rst @@ -11,60 +11,18 @@ .. role:: smallcaps -.. |A_1| replace:: `A`\ :math:`_{1}` -.. |A_n| replace:: `A`\ :math:`_{n}` -.. |arg_1| replace:: `arg`\ :math:`_{1}` -.. |arg_n| replace:: `arg`\ :math:`_{n}` -.. |bdi| replace:: :math:`\beta\delta\iota` -.. |binder_1| replace:: `binder`\ :math:`_{1}` -.. |binder_n| replace:: `binder`\ :math:`_{n}` -.. |binders_1| replace:: `binders`\ :math:`_{1}` -.. |binders_n| replace:: `binders`\ :math:`_{n}` -.. |C_1| replace:: `C`\ :math:`_{1}` .. |c_1| replace:: `c`\ :math:`_{1}` -.. |C_2| replace:: `C`\ :math:`_{2}` .. |c_i| replace:: `c`\ :math:`_{i}` .. |c_n| replace:: `c`\ :math:`_{n}` -.. |Cic| replace:: :smallcaps:`Cic` -.. |class_1| replace:: `class`\ :math:`_{1}` -.. |class_2| replace:: `class`\ :math:`_{2}` +.. |Cic| replace:: CIC .. |Coq| replace:: :smallcaps:`Coq` .. |CoqIDE| replace:: :smallcaps:`CoqIDE` .. |eq_beta_delta_iota_zeta| replace:: `=`\ :math:`_{\beta\delta\iota\zeta}` .. |Gallina| replace:: :smallcaps:`Gallina` -.. |ident_0| replace:: `ident`\ :math:`_{0}` -.. |ident_1,1| replace:: `ident`\ :math:`_{1,1}` -.. |ident_1,k_1| replace:: `ident`\ :math:`_{1,k_1}`) -.. |ident_1| replace:: `ident`\ :math:`_{1}` -.. |ident_2| replace:: `ident`\ :math:`_{2}` -.. |ident_3| replace:: `ident`\ :math:`_{3}` -.. |ident_i| replace:: `ident`\ :math:`_{i}` -.. |ident_j| replace:: `ident`\ :math:`_{j}` -.. |ident_k| replace:: `ident`\ :math:`_{k}` -.. |ident_n,1| replace:: `ident`\ :math:`_{n,1}` -.. |ident_n,k_n| replace:: `ident`\ :math:`_{n,k_n}` -.. |ident_n| replace:: `ident`\ :math:`_{n}` .. |Latex| replace:: :smallcaps:`LaTeX` .. |L_tac| replace:: `L`:sub:`tac` .. |Ltac| replace:: `L`:sub:`tac` .. |ML| replace:: :smallcaps:`ML` -.. |mod_0| replace:: `mod`\ :math:`_{0}` -.. |mod_1| replace:: `mod`\ :math:`_{1}` -.. |mod_2| replace:: `mod`\ :math:`_{1}` -.. |mod_n| replace:: `mod`\ :math:`_{n}` -.. |module_0| replace:: `module`\ :math:`_{0}` -.. |module_1| replace:: `module`\ :math:`_{1}` -.. |module_expression_0| replace:: `module_expression`\ :math:`_{0}` -.. |module_expression_1| replace:: `module_expression`\ :math:`_{1}` -.. |module_expression_i| replace:: `module_expression`\ :math:`_{i}` -.. |module_expression_n| replace:: `module_expression`\ :math:`_{n}` -.. |module_n| replace:: `module`\ :math:`_{n}` -.. |module_type_0| replace:: `module_type`\ :math:`_{0}` -.. |module_type_1| replace:: `module_type`\ :math:`_{1}` -.. |module_type_i| replace:: `module_type`\ :math:`_{i}` -.. |module_type_n| replace:: `module_type`\ :math:`_{n}` -.. |N| replace:: ``N`` -.. |nat| replace:: ``nat`` .. |OCaml| replace:: :smallcaps:`OCaml` .. |p_1| replace:: `p`\ :math:`_{1}` .. |p_i| replace:: `p`\ :math:`_{i}` @@ -79,24 +37,6 @@ .. |t_i| replace:: `t`\ :math:`_{i}` .. |t_m| replace:: `t`\ :math:`_{m}` .. |t_n| replace:: `t`\ :math:`_{n}` -.. |f_1| replace:: `f`\ :math:`_{1}` -.. |f_i| replace:: `f`\ :math:`_{i}` -.. |f_m| replace:: `f`\ :math:`_{m}` -.. |f_n| replace:: `f`\ :math:`_{n}` -.. |u_1| replace:: `u`\ :math:`_{1}` -.. |u_i| replace:: `u`\ :math:`_{i}` -.. |u_m| replace:: `u`\ :math:`_{m}` -.. |u_n| replace:: `u`\ :math:`_{n}` -.. |term_0| replace:: `term`\ :math:`_{0}` -.. |term_1| replace:: `term`\ :math:`_{1}` -.. |term_2| replace:: `term`\ :math:`_{2}` -.. |term_n| replace:: `term`\ :math:`_{n}` -.. |type_0| replace:: `type`\ :math:`_{0}` -.. |type_1| replace:: `type`\ :math:`_{1}` -.. |type_2| replace:: `type`\ :math:`_{2}` -.. |type_3| replace:: `type`\ :math:`_{3}` -.. |type_n| replace:: `type`\ :math:`_{n}` .. |x_1| replace:: `x`\ :math:`_{1}` .. |x_i| replace:: `x`\ :math:`_{i}` .. |x_n| replace:: `x`\ :math:`_{n}` -.. |Z| replace:: ``Z`` diff --git a/doc/sphinx/refman-preamble.sty b/doc/sphinx/refman-preamble.sty index 90a63a5a2d..629c30a793 100644 --- a/doc/sphinx/refman-preamble.sty +++ b/doc/sphinx/refman-preamble.sty @@ -1,32 +1,20 @@ -\newcommand{\alors}{\textsf{then}} -\newcommand{\alter}{\textsf{alter}} \newcommand{\as}{\kw{as}} \newcommand{\Assum}[3]{\kw{Assum}(#1)(#2:#3)} -\newcommand{\bool}{\textsf{bool}} \newcommand{\case}{\kw{case}} -\newcommand{\conc}{\textsf{conc}} \newcommand{\cons}{\textsf{cons}} \newcommand{\consf}{\textsf{consf}} -\newcommand{\conshl}{\textsf{cons\_hl}} \newcommand{\Def}[4]{\kw{Def}(#1)(#2:=#3:#4)} \newcommand{\emptyf}{\textsf{emptyf}} \newcommand{\End}{\kw{End}} \newcommand{\kwend}{\kw{end}} -\newcommand{\EqSt}{\textsf{EqSt}} \newcommand{\even}{\textsf{even}} \newcommand{\evenO}{\textsf{even}_\textsf{O}} \newcommand{\evenS}{\textsf{even}_\textsf{S}} -\newcommand{\false}{\textsf{false}} -\newcommand{\filter}{\textsf{filter}} \newcommand{\Fix}{\kw{Fix}} \newcommand{\fix}{\kw{fix}} \newcommand{\for}{\textsf{for}} \newcommand{\forest}{\textsf{forest}} -\newcommand{\from}{\textsf{from}} \newcommand{\Functor}{\kw{Functor}} -\newcommand{\haslength}{\textsf{has\_length}} -\newcommand{\hd}{\textsf{hd}} -\newcommand{\ident}{\textsf{ident}} \newcommand{\In}{\kw{in}} \newcommand{\Ind}[4]{\kw{Ind}[#2](#3:=#4)} \newcommand{\ind}[3]{\kw{Ind}~[#1]\left(#2\mathrm{~:=~}#3\right)} @@ -34,7 +22,6 @@ \newcommand{\Indpstr}[6]{\kw{Ind}_{#5}(#1)[#2](#3:=#4)/{#6}} \newcommand{\injective}{\kw{injective}} \newcommand{\kw}[1]{\textsf{#1}} -\newcommand{\lb}{\lambda} \newcommand{\length}{\textsf{length}} \newcommand{\letin}[3]{\kw{let}~#1:=#2~\kw{in}~#3} \newcommand{\List}{\textsf{list}} @@ -45,7 +32,6 @@ \newcommand{\ModS}[2]{{\kw{Mod}}({#1}:{#2})} \newcommand{\ModType}[2]{{\kw{ModType}}({#1}:={#2})} \newcommand{\mto}{.\;} -\newcommand{\Nat}{\mathbb{N}} \newcommand{\nat}{\textsf{nat}} \newcommand{\Nil}{\textsf{nil}} \newcommand{\nilhl}{\textsf{nil\_hl}} @@ -57,13 +43,10 @@ \newcommand{\ovl}[1]{\overline{#1}} \newcommand{\Pair}{\textsf{pair}} \newcommand{\plus}{\mathsf{plus}} -\newcommand{\Prod}{\textsf{prod}} \newcommand{\SProp}{\textsf{SProp}} \newcommand{\Prop}{\textsf{Prop}} \newcommand{\return}{\kw{return}} \newcommand{\Set}{\textsf{Set}} -\newcommand{\si}{\textsf{if}} -\newcommand{\sinon}{\textsf{else}} \newcommand{\Sort}{\mathcal{S}} \newcommand{\Str}{\textsf{Stream}} \newcommand{\Struct}{\kw{Struct}} @@ -71,9 +54,7 @@ \newcommand{\tl}{\textsf{tl}} \newcommand{\tree}{\textsf{tree}} \newcommand{\trii}{\triangleright_\iota} -\newcommand{\true}{\textsf{true}} \newcommand{\Type}{\textsf{Type}} -\newcommand{\unfold}{\textsf{unfold}} \newcommand{\WEV}[3]{\mbox{$#1[] \vdash #2 \lra #3$}} \newcommand{\WEVT}[3]{\mbox{$#1[] \vdash #2 \lra$}\\ \mbox{$ #3$}} \newcommand{\WF}[2]{{\mathcal{W\!F}}(#1)[#2]} @@ -88,4 +69,3 @@ \newcommand{\WTEG}[2]{\WTE{\Gamma}{#1}{#2}} \newcommand{\WTM}[3]{\WT{#1}{}{#2}{#3}} \newcommand{\zeroone}[1]{[{#1}]} -\newcommand{\zeros}{\textsf{zeros}} diff --git a/doc/sphinx/using/libraries/index.rst b/doc/sphinx/using/libraries/index.rst new file mode 100644 index 0000000000..d0848e6c3f --- /dev/null +++ b/doc/sphinx/using/libraries/index.rst @@ -0,0 +1,24 @@ +.. _libraries: + +===================== +Libraries and plugins +===================== + +Coq is distributed with a standard library and a set of internal +plugins (most of which provide tactics that have already been +presented in :ref:`writing-proofs`). This chapter presents this +standard library and some of these internal plugins which provide +features that are not tactics. + +In addition, Coq has a rich ecosystem of external libraries and +plugins. These libraries and plugins can be browsed online through +the `Coq Package Index <https://coq.inria.fr/opam/www/>`_ and +installed with the `opam package manager +<https://coq.inria.fr/opam-using.html>`_. + +.. toctree:: + :maxdepth: 1 + + ../../language/coq-library + ../../addendum/extraction + ../../addendum/miscellaneous-extensions diff --git a/doc/sphinx/using/tools/coqdoc.rst b/doc/sphinx/using/tools/coqdoc.rst new file mode 100644 index 0000000000..cada680895 --- /dev/null +++ b/doc/sphinx/using/tools/coqdoc.rst @@ -0,0 +1,463 @@ +.. _coqdoc: + +Documenting |Coq| files with coqdoc +----------------------------------- + +coqdoc is a documentation tool for the proof assistant |Coq|, similar to +``javadoc`` or ``ocamldoc``. The task of coqdoc is + + +#. to produce a nice |Latex| and/or HTML document from |Coq| source files, + readable for a human and not only for the proof assistant; +#. to help the user navigate his own (or third-party) sources. + + + +Principles +~~~~~~~~~~ + +Documentation is inserted into |Coq| files as *special comments*. Thus +your files will compile as usual, whether you use coqdoc or not. coqdoc +presupposes that the given |Coq| files are well-formed (at least +lexically). Documentation starts with ``(**``, followed by a space, and +ends with ``*)``. The documentation format is inspired by Todd +A. Coram’s *Almost Free Text (AFT)* tool: it is mainly ``ASCII`` text with +some syntax-light controls, described below. coqdoc is robust: it +shouldn’t fail, whatever the input is. But remember: “garbage in, +garbage out”. + + +|Coq| material inside documentation. +++++++++++++++++++++++++++++++++++++ + +|Coq| material is quoted between the delimiters ``[`` and ``]``. Square brackets +may be nested, the inner ones being understood as being part of the +quoted code (thus you can quote a term like ``fun x => u`` by writing ``[fun +x => u]``). Inside quotations, the code is pretty-printed in the same +way as it is in code parts. + +Preformatted vernacular is enclosed by ``[[`` and ``]]``. The former must be +followed by a newline and the latter must follow a newline. + + +Pretty-printing. +++++++++++++++++ + +coqdoc uses different faces for identifiers and keywords. The pretty- +printing of |Coq| tokens (identifiers or symbols) can be controlled +using one of the following commands: + +:: + + + (** printing *token* %...LATEX...% #...html...# *) + + +or + +:: + + + (** printing *token* $...LATEX math...$ #...html...# *) + + +It gives the |Latex| and HTML texts to be produced for the given |Coq| +token. Either the |Latex| or the HTML rule may be omitted, causing the +default pretty-printing to be used for this token. + +The printing for one token can be removed with + +:: + + + (** remove printing *token* *) + + +Initially, the pretty-printing table contains the following mapping: + +===== === ==== ===== === ==== ==== === +`->` → `<-` ← `*` × +`<=` ≤ `>=` ≥ `=>` ⇒ +`<>` ≠ `<->` ↔ `|-` ⊢ +`\\/` ∨ `/\\` ∧ `~` ¬ +===== === ==== ===== === ==== ==== === + +Any of these can be overwritten or suppressed using the printing +commands. + +.. note:: + + The recognition of tokens is done by a (``ocaml``) lex + automaton and thus applies the longest-match rule. For instance, `->~` + is recognized as a single token, where |Coq| sees two tokens. It is the + responsibility of the user to insert space between tokens *or* to give + pretty-printing rules for the possible combinations, e.g. + + :: + + (** printing ->~ %\ensuremath{\rightarrow\lnot}% *) + + + +Sections +++++++++ + +Sections are introduced by 1 to 4 asterisks at the beginning of a line +followed by a space and the title of the section. One asterisk is a section, +two a subsection, etc. + +.. example:: + + :: + + (** * Well-founded relations + + In this section, we introduce... *) + + +Lists. +++++++ + +List items are introduced by a leading dash. coqdoc uses whitespace to +determine the depth of a new list item and which text belongs in which +list items. A list ends when a line of text starts at or before the +level of indenting of the list’s dash. A list item’s dash must always +be the first non-space character on its line (so, in particular, a +list can not begin on the first line of a comment - start it on the +second line instead). + +.. example:: + + :: + + We go by induction on [n]: + - If [n] is 0... + - If [n] is [S n'] we require... + + two paragraphs of reasoning, and two subcases: + + - In the first case... + - In the second case... + + So the theorem holds. + + + +Rules. +++++++ + +More than 4 leading dashes produce a horizontal rule. + + +Emphasis. ++++++++++ + +Text can be italicized by enclosing it in underscores. A non-identifier +character must precede the leading underscore and follow the trailing +underscore, so that uses of underscores in names aren’t mistaken for +emphasis. Usually, these are spaces or punctuation. + +:: + + This sentence contains some _emphasized text_. + + + +Escaping to |Latex| and HTML. ++++++++++++++++++++++++++++++++ + +Pure |Latex| or HTML material can be inserted using the following +escape sequences: + + ++ ``$...LATEX stuff...$`` inserts some |Latex| material in math mode. + Simply discarded in HTML output. ++ ``%...LATEX stuff...%`` inserts some |Latex| material. Simply + discarded in HTML output. ++ ``#...HTML stuff...#`` inserts some HTML material. Simply discarded in + |Latex| output. + +.. note:: + to simply output the characters ``$``, ``%`` and ``#`` and escaping + their escaping role, these characters must be doubled. + + +Verbatim +++++++++ + +Verbatim material is introduced by a leading ``<<`` and closed by ``>>`` +at the beginning of a line. + +.. example:: + + :: + + Here is the corresponding caml code: + << + let rec fact n = + if n <= 1 then 1 else n * fact (n-1) + >> + + + +Hyperlinks +++++++++++ + +Hyperlinks can be inserted into the HTML output, so that any +identifier is linked to the place of its definition. + +``coqc file.v`` automatically dumps localization information in +``file.glob`` or appends it to a file specified using the option ``--dump-glob +file``. Take care of erasing this global file, if any, when starting +the whole compilation process. + +Then invoke coqdoc or ``coqdoc --glob-from file`` to tell coqdoc to look +for name resolutions in the file ``file`` (it will look in ``file.glob`` +by default). + +Identifiers from the |Coq| standard library are linked to the Coq website +`<http://coq.inria.fr/library/>`_. This behavior can be changed +using command line options ``--no-externals`` and ``--coqlib``; see below. + + +Hiding / Showing parts of the source. ++++++++++++++++++++++++++++++++++++++ + +Some parts of the source can be hidden using command line options ``-g`` +and ``-l`` (see below), or using such comments: + +:: + + + (* begin hide *) + *some Coq material* + (* end hide *) + + +Conversely, some parts of the source which would be hidden can be +shown using such comments: + +:: + + + (* begin show *) + *some Coq material* + (* end show *) + + +The latter cannot be used around some inner parts of a proof, but can +be used around a whole proof. + + +Usage +~~~~~ + +coqdoc is invoked on a shell command line as follows: +``coqdoc <options and files>``. +Any command line argument which is not an option is considered to be a +file (even if it starts with a ``-``). |Coq| files are identified by the +suffixes ``.v`` and ``.g`` and |Latex| files by the suffix ``.tex``. + + +:HTML output: This is the default output format. One HTML file is created for + each |Coq| file given on the command line, together with a file + ``index.html`` (unless ``option-no-index is passed``). The HTML pages use a + style sheet named ``style.css``. Such a file is distributed with coqdoc. +:|Latex| output: A single |Latex| file is created, on standard + output. It can be redirected to a file using the option ``-o``. The order of + files on the command line is kept in the final document. |Latex| + files given on the command line are copied ‘as is’ in the final + document . DVI and PostScript can be produced directly with the + options ``-dvi`` and ``-ps`` respectively. +:TEXmacs output: To translate the input files to TEXmacs format, + to be used by the TEXmacs |Coq| interface. + + + +Command line options +++++++++++++++++++++ + + +**Overall options** + + + :--HTML: Select a HTML output. + :--|Latex|: Select a |Latex| output. + :--dvi: Select a DVI output. + :--ps: Select a PostScript output. + :--texmacs: Select a TEXmacs output. + :--stdout: Write output to stdout. + :-o file, --output file: Redirect the output into the file ‘file’ + (meaningless with ``-html``). + :-d dir, --directory dir: Output files into directory ‘dir’ instead of + the current directory (option ``-d`` does not change the filename specified + with the option ``-o``, if any). + :--body-only: Suppress the header and trailer of the final document. + Thus, you can insert the resulting document into a larger one. + :-p string, --preamble string: Insert some material in the |Latex| + preamble, right before ``\begin{document}`` (meaningless with ``-html``). + :--vernac-file file,--tex-file file: Considers the file ‘file’ + respectively as a ``.v`` (or ``.g``) file or a ``.tex`` file. + :--files-from file: Read filenames to be processed from the file ‘file’ as if + they were given on the command line. Useful for program sources split + up into several directories. + :-q, --quiet: Be quiet. Do not print anything except errors. + :-h, --help: Give a short summary of the options and exit. + :-v, --version: Print the version and exit. + + + +**Index options** + + The default behavior is to build an index, for the HTML output only, + into ``index.html``. + + :--no-index: Do not output the index. + :--multi-index: Generate one page for each category and each letter in + the index, together with a top page ``index.html``. + :--index string: Make the filename of the index string instead of + “index”. Useful since “index.html” is special. + + + +**Table of contents option** + + :-toc, --table-of-contents: Insert a table of contents. For a |Latex| + output, it inserts a ``\tableofcontents`` at the beginning of the + document. For a HTML output, it builds a table of contents into + ``toc.html``. + :--toc-depth int: Only include headers up to depth ``int`` in the table of + contents. + + +**Hyperlink options** + + :--glob-from file: Make references using |Coq| globalizations from file + file. (Such globalizations are obtained with Coq option ``-dump-glob``). + :--no-externals: Do not insert links to the |Coq| standard library. + :--external url coqdir: Use given URL for linking references whose + name starts with prefix ``coqdir``. + :--coqlib url: Set base URL for the Coq standard library (default is + `<http://coq.inria.fr/library/>`_). This is equivalent to ``--external url + Coq``. + :-R dir coqdir: Recursively map physical directory dir to |Coq| logical + directory ``coqdir`` (similarly to |Coq| option ``-R``). + :-Q dir coqdir: Map physical directory dir to |Coq| logical + directory ``coqdir`` (similarly to |Coq| option ``-Q``). + + .. note:: + + options ``-R`` and ``-Q`` only have + effect on the files *following* them on the command line, so you will + probably need to put this option first. + + +**Title options** + + :-s , --short: Do not insert titles for the files. The default + behavior is to insert a title like “Library Foo” for each file. + :--lib-name string: Print “string Foo” instead of “Library Foo” in + titles. For example “Chapter” and “Module” are reasonable choices. + :--no-lib-name: Print just “Foo” instead of “Library Foo” in titles. + :--lib-subtitles: Look for library subtitles. When enabled, the + beginning of each file is checked for a comment of the form: + + :: + + (** * ModuleName : text *) + + where ``ModuleName`` must be the name of the file. If it is present, the + text is used as a subtitle for the module in appropriate places. + :-t string, --title string: Set the document title. + + +**Contents options** + + :-g, --gallina: Do not print proofs. + :-l, --light: Light mode. Suppress proofs (as with ``-g``) and the following commands: + + + [Recursive] Tactic Definition + + Hint / Hints + + Require + + Transparent / Opaque + + Implicit Argument / Implicits + + Section / Variable / Hypothesis / End + + + + The behavior of options ``-g`` and ``-l`` can be locally overridden using the + ``(* begin show *) … (* end show *)`` environment (see above). + + There are a few options that control the parsing of comments: + + :--parse-comments: Parse regular comments delimited by ``(*`` and ``*)`` as + well. They are typeset inline. + :--plain-comments: Do not interpret comments, simply copy them as + plain-text. + :--interpolate: Use the globalization information to typeset + identifiers appearing in |Coq| escapings inside comments. + +**Language options** + + + The default behavior is to assume ASCII 7 bit input files. + + :-latin1, --latin1: Select ISO-8859-1 input files. It is equivalent to + --inputenc latin1 --charset iso-8859-1. + :-utf8, --utf8: Set --inputenc utf8x for |Latex| output and--charset + utf-8 for HTML output. Also use Unicode replacements for a couple of + standard plain ASCII notations such as → for ``->`` and ∀ for ``forall``. |Latex| + UTF-8 support can be found + at `<http://www.ctan.org/pkg/unicode>`_. For the interpretation of Unicode + characters by |Latex|, extra packages which coqdoc does not provide + by default might be required, such as textgreek for some Greek letters + or ``stmaryrd`` for some mathematical symbols. If a Unicode character is + missing an interpretation in the utf8x input encoding, add + ``\DeclareUnicodeCharacter{code}{LATEX-interpretation}``. Packages + and declarations can be added with option ``-p``. + :--inputenc string: Give a |Latex| input encoding, as an option to |Latex| + package ``inputenc``. + :--charset string: Specify the HTML character set, to be inserted in + the HTML header. + + + +The coqdoc |Latex| style file +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +In case you choose to produce a document without the default |Latex| +preamble (by using option ``--no-preamble``), then you must insert into +your own preamble the command + +:: + + \usepackage{coqdoc} + +The package optionally takes the argument ``[color]`` to typeset +identifiers with colors (this requires the ``xcolor`` package). + +Then you may alter the rendering of the document by redefining some +macros: + +:coqdockw, coqdocid, …: The one-argument macros for typesetting + keywords and identifiers. Defaults are sans-serif for keywords and + italic for identifiers.For example, if you would like a slanted font + for keywords, you may insert + + :: + + \renewcommand{\coqdockw}[1]{\textsl{#1}} + + + anywhere between ``\usepackage{coqdoc}`` and ``\begin{document}``. + + +:coqdocmodule: + One-argument macro for typesetting the title of a ``.v`` + file. Default is + + :: + + \newcommand{\coqdocmodule}[1]{\section*{Module #1}} + + and you may redefine it using ``\renewcommand``. diff --git a/doc/sphinx/using/tools/index.rst b/doc/sphinx/using/tools/index.rst new file mode 100644 index 0000000000..dfe38dfce9 --- /dev/null +++ b/doc/sphinx/using/tools/index.rst @@ -0,0 +1,21 @@ +.. _tools: + +================================ +Command-line and graphical tools +================================ + +This chapter presents the command-line tools that users will need to +build their Coq project, the documentation of the CoqIDE standalone +user interface and the documentation of the parallel proof processing +feature that is supported by CoqIDE and several other user interfaces. +A list of available user interfaces to interact with Coq is available +on the `Coq website <https://coq.inria.fr/user-interfaces.html>`_. + +.. toctree:: + :maxdepth: 1 + + ../../practical-tools/coq-commands + ../../practical-tools/utilities + coqdoc + ../../practical-tools/coqide + ../../addendum/parallel-proof-processing diff --git a/doc/stdlib/dune b/doc/stdlib/dune index 093c7a62b2..0b6ca5f178 100644 --- a/doc/stdlib/dune +++ b/doc/stdlib/dune @@ -13,6 +13,8 @@ (rule (targets html) + (alias stdlib-html) + (package coq-doc) (deps ; This will be replaced soon by `theories/**/*.v` soon, thanks to rgrinberg (source_tree %{project_root}/theories) @@ -31,6 +33,12 @@ (progn (cat %{header}) (cat index-list.html) (cat %{footer}))) (run cp _index.html html/index.html)))) -(alias - (name stdlib-html) - (deps html)) +; Installable directories are not yet fully supported by Dune. See +; ocaml/dune#1868. Yet, this makes coq-doc.install a valid target to +; generate the whole Coq documentation. And the result under +; _build/install/default/doc/coq-doc looks just right! + +(install + (files (html as html/stdlib)) + (section doc) + (package coq-doc)) diff --git a/doc/stdlib/hidden-files b/doc/stdlib/hidden-files index 60d6039b0f..67d0b37e81 100644 --- a/doc/stdlib/hidden-files +++ b/doc/stdlib/hidden-files @@ -50,6 +50,7 @@ theories/micromega/ZifyInst.v theories/micromega/ZifyBool.v theories/micromega/ZifyComparison.v theories/micromega/ZifyClasses.v +theories/micromega/ZifyPow.v theories/micromega/Zify.v theories/nsatz/Nsatz.v theories/omega/Omega.v diff --git a/doc/stdlib/index-list.html.template b/doc/stdlib/index-list.html.template index 0f05237036..e64b4be454 100644 --- a/doc/stdlib/index-list.html.template +++ b/doc/stdlib/index-list.html.template @@ -528,13 +528,17 @@ through the <tt>Require Import</tt> command.</p> </dt> <dd> theories/Reals/Rdefinitions.v - theories/Reals/ConstructiveReals.v - theories/Reals/ConstructiveRealsMorphisms.v - theories/Reals/ConstructiveCauchyReals.v - theories/Reals/ConstructiveCauchyRealsMult.v + theories/Reals/Cauchy/ConstructiveCauchyReals.v + theories/Reals/Cauchy/ConstructiveCauchyRealsMult.v + theories/Reals/Cauchy/ConstructiveCauchyAbs.v theories/Reals/ClassicalDedekindReals.v theories/Reals/Raxioms.v - theories/Reals/ConstructiveRealsLUB.v + theories/Reals/Abstract/ConstructiveReals.v + theories/Reals/Abstract/ConstructiveRealsMorphisms.v + theories/Reals/Abstract/ConstructiveLUB.v + theories/Reals/Abstract/ConstructiveAbs.v + theories/Reals/Abstract/ConstructiveLimits.v + theories/Reals/Abstract/ConstructiveSum.v theories/Reals/RIneq.v theories/Reals/DiscrR.v theories/Reals/ROrderedType.v @@ -579,7 +583,7 @@ through the <tt>Require Import</tt> command.</p> theories/Reals/Ranalysis5.v theories/Reals/Ranalysis_reg.v theories/Reals/Rcomplete.v - theories/Reals/ConstructiveRcomplete.v + theories/Reals/Cauchy/ConstructiveRcomplete.v theories/Reals/RiemannInt.v theories/Reals/RiemannInt_SF.v theories/Reals/Rpow_def.v diff --git a/doc/stdlib/make-library-index b/doc/stdlib/make-library-index index a51308f153..cb93a4c8cc 100755 --- a/doc/stdlib/make-library-index +++ b/doc/stdlib/make-library-index @@ -36,7 +36,8 @@ for k in $LIBDIRS; do fi else if [ $h = 0 ]; then - echo Warning: $k/$b.v will be hidden from the index + # Skipping file from the index + : else echo Error: none of $FILE and $HIDDEN mention $k/$b.v exit 1 diff --git a/doc/tools/coqrst/coqdomain.py b/doc/tools/coqrst/coqdomain.py index b92c94fe2c..6332c4c81d 100644 --- a/doc/tools/coqrst/coqdomain.py +++ b/doc/tools/coqrst/coqdomain.py @@ -34,7 +34,6 @@ from sphinx.util.logging import getLogger, get_node_location from sphinx.directives import ObjectDescription from sphinx.domains import Domain, ObjType, Index from sphinx.domains.std import token_xrefs -from sphinx.ext import mathbase from . import coqdoc from .repl import ansicolors @@ -74,8 +73,7 @@ def make_target(objtype, targetid): return "coq:{}.{}".format(objtype, targetid) def make_math_node(latex, docname, nowrap): - node = mathbase.displaymath() - node['latex'] = latex + node = nodes.math_block(latex, latex) node['label'] = None # Otherwise equations are numbered node['nowrap'] = nowrap node['docname'] = docname @@ -339,7 +337,7 @@ class TacticNotationObject(NotationObject): """ subdomain = "tacn" index_suffix = "(tactic)" - annotation = None + annotation = "Tactic" class AttributeNotationObject(NotationObject): """An attribute. @@ -493,9 +491,7 @@ class ProductionObject(CoqObject): pass def _target_id(self, name): - # Use `name[1]` instead of ``nodes.make_id(name[1])`` to work around - # https://github.com/sphinx-doc/sphinx/issues/4983 - return 'grammar-token-{}'.format(name[1]) + return 'grammar-token-{}'.format(nodes.make_id(name[1])) def _record_name(self, name, targetid): env = self.state.document.settings.env @@ -523,7 +519,7 @@ class ProductionObject(CoqObject): row = nodes.inline(classes=['prodn-row']) entry = nodes.inline(classes=['prodn-cell-nonterminal']) if lhs != "": - target_name = 'grammar-token-' + lhs + target_name = 'grammar-token-' + nodes.make_id(lhs) target = nodes.target('', '', ids=[target_name], names=[target_name]) # putting prodn-target on the target node won't appear in the tex file inline = nodes.inline(classes=['prodn-target']) diff --git a/doc/tools/docgram/README.md b/doc/tools/docgram/README.md index 8f325f957a..4cde3809f0 100644 --- a/doc/tools/docgram/README.md +++ b/doc/tools/docgram/README.md @@ -1,13 +1,13 @@ # Grammar extraction tool for documentation -`doc_grammar` extracts Coq's grammar from `.mlg` files, edits it and -inserts it in chunks into `.rst` files. The tool currently inserts -Sphinx `productionlist` and `prodn` constructs (`productionlist` are -gradually being replaced by `prodn` in the manual). Updates to `tacn` -and `cmd` constructs must be done manually since the grammar doesn't -have names for them as it does for nonterminals. There is an option -to report which `tacn` and `cmd` were not found in the `.rst` files. -`tacv` and `cmdv` constructs are not processed at all. +`doc_grammar` extracts Coq's grammar from `.mlg` files, edits it and inserts it +into `.rst` files. The tool inserts `prodn` directives for grammar productions. +(`productionlist` are gradually being replaced by `prodn` in the manual.) +It also updates `tacn` and `cmd` directives when they can be unambiguously matched to +productions of the grammar (in practice, that's probably almost always). +`tacv` and `cmdv` directives are not updated because matching them appears to require +human judgement. `doc_grammar` generates a few files that may be useful to +developers and documentors. The mlg grammars present several challenges to generating an accurate grammar for documentation purposes: @@ -34,46 +34,49 @@ for documentation purposes: ## What the tool does -1. The tool reads all the `mlg` files and generates `fullGrammar`, which includes -all the grammar without the actions for each production or the OCaml code. This -file is provided as a convenience to make it easier to examine the (mostly) -unprocessed grammar of the mlg files with less clutter. Nonterminals that use -levels (`"5" RIGHTA` below) are modified, for example: - -``` -tactic_expr: - [ "5" RIGHTA - [ te = binder_tactic -> { te } ] -``` - -becomes - -``` -tactic_expr5: [ -| binder_tactic -| tactic_expr4 -] -``` - -2. The tool applies grammar editing operations specified by `common.edit_mlg` to -generate `editedGrammar`. - -3. `orderedGrammar` gives the desired order for the nonterminals and productions -in the documented grammar. Developers should edit this file to change the order. -`doc_grammar` updates `orderedGrammar` so it has the same set of nonterminals and productions -as `editedGrammar`. The update process removes manually-added comments from -`orderedGrammar` while automatically-generated comments will be regenerated. - -4. The tool applies further edits to the grammar specified by `productionlist.edit_mlg`, -then it updates the productionlists in the `.rst` files as specified by comments in the form -`.. insertgram <first nt> <last nt>`. The edits are primarily to expand -`.mlg` constructs such as `LIST1` and `OPT` into separate productions. The tool -generates `productionlistGrammar`, which has the entire grammar in the form of `productionlists`. - -5. Using the grammar produced in step 3, the tool applies edits specified by -`prodn.edit_mlg` and generates `prodnGrammar`, representing each production as -a Sphinx `prodn` construct. Differently-edited grammars are used because `prodn` -can naturally represent `LIST1 x SEP ','` whereas that is awkward for `productionlists`. +1. The tool reads all the `mlg` files and generates `fullGrammar`, which includes + all the grammar without the actions for each production or the OCaml code. This + file is provided as a convenience to make it easier to examine the (mostly) + unprocessed grammar of the mlg files with less clutter. Nonterminals that use + levels (`"5" RIGHTA` below) are modified, for example: + + ``` + tactic_expr: + [ "5" RIGHTA + [ te = binder_tactic -> { te } ] + ``` + + becomes + + ``` + tactic_expr5: [ + | binder_tactic + | tactic_expr4 + ] + ``` + +2. The tool applies grammar editing operations specified by `common.edit_mlg` to + generate `editedGrammar`. + +3. `orderedGrammar` gives the desired order for nonterminals and individual productions + in the documented grammar. Developers should edit this file only to reorder lines. + `doc_grammar` updates `orderedGrammar` so it has the same set of nonterminals and productions + as `editedGrammar` while retaining the previous ordering. Since the position of + new or renamed nonterminals is unspecified, they tend to show up in the wrong + place in `orderedGrammar`, therefore users should review the output and make + appropriate adjustments to the order. + + The update process removes manually-added comments from `orderedGrammar` while + automatically-generated comments will be regenerated. + +4. The tool updates the `.rst` files. Comments in the form + `.. insertprodn <first nt> <last nt>` indicate inserting the productions for a + range of nonterminals. `.. cmd::` and `.. tacn::` directives are updated using + prefixes in the form `[a-zA-Z0-9_ ]+` from the directive and the + grammar. If there is unique match in the grammar, the directive is updated, if needed. + Multiple matches or no match gives an error message. + +5. For reference, the tool generates `prodnGrammar`, which has the entire grammar in the form of `prodns`. ## How to use the tool @@ -107,6 +110,9 @@ Other command line arguments: * `-no-warn` suppresses printing of some warning messages +* `-no-update` puts updates to `fullGrammar` and `orderedGrammar` into new files named + `*.new`, leaving the originals unmodified. For use in Dune. + * `-short` limits processing to updating/verifying only the `fullGrammar` file * `-verbose` prints more messages about the grammar @@ -115,12 +121,12 @@ Other command line arguments: ### Grammar editing scripts -The grammar editing scripts `*.edit_mlg` are similar in format to `.mlg` files stripped +The grammar editing script `common.edit_mlg` is similar in format to `.mlg` files but stripped of all OCaml features. This is an easy way to include productions to match or add without writing another parser. The `DOC_GRAMMAR` token at the beginning of each file -signals the use of streamlined syntax. +signals the use of the streamlined syntax. -Each edit file has a series of items in the form of productions. Items are applied +The edit file has a series of items in the form of productions. Items are applied in the order they appear. There are two types of editing operations: * Global edits - edit rules that apply to the entire grammar in a single operation. @@ -137,7 +143,7 @@ such as `empty: [ | ]`, which adds a new non-terminal `empty` with an empty production on the right-hand side. Another example: `LEFTQMARK: [ | "?" ]` is a local edit that treats `LEFTQMARK` as -the name of a non-terminal and adds one production for it. (We know that LEFTQMARK +the name of a non-terminal and adds a production for it. (We know that LEFTQMARK is a token but doc_grammar does not.) `SPLICE: [ | LEFTQMARK ]` requests replacing all uses of `LEFTQMARK` anywhere in the grammar with its productions and removing the non-terminal. The combined effect of these two is to replace all uses of @@ -192,7 +198,7 @@ that appear in the specified production: ``` `MOVETO <destination> <production>` - moves the production to `<destination>` and, - if needed, creates a new production <edited_nt> -> <destination>. + if needed, creates a new production <edited_nt> -> \<destination>. `OPTINREF` - verifies that <edited_nt> has an empty production. If so, it removes the empty production and replaces all references to <edited_nt> throughout the @@ -201,7 +207,7 @@ grammar with `OPT <edited_nt>` `PRINT` <nonterminal> - prints the nonterminal definition at that point in applying the edits. Most useful when the edits get a bit complicated to follow. -* (any other nonterminal name) - adds a new production (and possibly a new nonterminal) +`(any other nonterminal name)` - adds a new production (and possibly a new nonterminal) to the grammar. ### `.rst` file updates diff --git a/doc/tools/docgram/common.edit_mlg b/doc/tools/docgram/common.edit_mlg index fe2e68a517..60b845c4be 100644 --- a/doc/tools/docgram/common.edit_mlg +++ b/doc/tools/docgram/common.edit_mlg @@ -140,10 +140,10 @@ field_ident: [ | "." ident ] -basequalid: [ -| REPLACE ident fields -| WITH ident LIST0 field_ident -| DELETE ident +qualid: [ | DELETENT ] + +qualid: [ +| ident LIST0 field_ident ] field: [ | DELETENT ] @@ -313,6 +313,7 @@ closed_binder: [ | REPLACE "{" name LIST1 name ":" lconstr "}" | WITH "{" LIST1 name type_cstr "}" | DELETE "{" name ":" lconstr "}" +| MOVETO implicit_binders "{" LIST1 name type_cstr "}" | DELETE "[" name "]" | DELETE "[" name LIST1 name "]" @@ -320,9 +321,14 @@ closed_binder: [ | REPLACE "[" name LIST1 name ":" lconstr "]" | WITH "[" LIST1 name type_cstr "]" | DELETE "[" name ":" lconstr "]" +| MOVETO implicit_binders "[" LIST1 name type_cstr "]" | REPLACE "(" Prim.name ":" lconstr "|" lconstr ")" | WITH "(" Prim.name ":" type "|" lconstr ")" + +| MOVETO generalizing_binder "`(" LIST1 typeclass_constraint SEP "," ")" +| MOVETO generalizing_binder "`{" LIST1 typeclass_constraint SEP "," "}" +| MOVETO generalizing_binder "`[" LIST1 typeclass_constraint SEP "," "]" ] name_colon: [ @@ -383,15 +389,25 @@ evar_instance: [ | OPTINREF ] +(* No constructor syntax, OPT [ "|" binders ] is not supported for Record *) +record_definition: [ +| opt_coercion ident_decl binders OPT [ ":" type ] OPT [ identref ] "{" record_fields "}" decl_notations +] + +(* No record syntax, opt_coercion not supported for Variant, := ... required *) +variant_definition: [ +| ident_decl binders OPT [ "|" binders ] OPT [ ":" type ] ":=" OPT "|" LIST1 constructor SEP "|" decl_notations +] + gallina: [ | REPLACE thm_token ident_decl binders ":" lconstr LIST0 [ "with" ident_decl binders ":" lconstr ] | WITH thm_token ident_decl binders ":" type LIST0 [ "with" ident_decl binders ":" type ] | DELETE assumptions_token inline assum_list -| REPLACE OPT cumulativity_token private_token finite_token LIST1 inductive_definition SEP "with" +| REPLACE finite_token LIST1 inductive_definition SEP "with" | WITH "Inductive" inductive_definition LIST0 ( "with" inductive_definition ) | "CoInductive" inductive_definition LIST0 ( "with" inductive_definition ) -| "Variant" inductive_definition LIST0 ( "with" inductive_definition ) -| [ "Record" | "Structure" ] inductive_definition LIST0 ( "with" inductive_definition ) +| "Variant" variant_definition LIST0 ( "with" variant_definition ) +| [ "Record" | "Structure" ] record_definition LIST0 ( "with" record_definition ) | "Class" inductive_definition LIST0 ( "with" inductive_definition ) | REPLACE "Fixpoint" LIST1 rec_definition SEP "with" | WITH "Fixpoint" rec_definition LIST0 ( "with" rec_definition ) @@ -405,18 +421,13 @@ gallina: [ | WITH "Scheme" scheme LIST0 ( "with" scheme ) ] -DELETE: [ -| private_token -| cumulativity_token -] - constructor_list_or_record_decl: [ | OPTINREF ] record_fields: [ | REPLACE record_field ";" record_fields -| WITH LIST1 record_field SEP ";" +| WITH LIST0 record_field SEP ";" | DELETE record_field | DELETE (* empty *) ] @@ -492,16 +503,46 @@ functor_app_annot: [ ] is_module_expr: [ +| REPLACE ":=" module_expr_inl LIST0 ext_module_expr +| WITH ":=" LIST1 module_expr_inl SEP "<+" | OPTINREF ] is_module_type: [ +| REPLACE ":=" module_type_inl LIST0 ext_module_type +| WITH ":=" LIST1 module_type_inl SEP "<+" | OPTINREF ] gallina_ext: [ | REPLACE "Arguments" smart_global LIST0 argument_spec_block OPT [ "," LIST1 [ LIST0 more_implicits_block ] SEP "," ] OPT [ ":" LIST1 arguments_modifier SEP "," ] | WITH "Arguments" smart_global LIST0 argument_spec_block LIST0 [ "," LIST0 more_implicits_block ] OPT [ ":" LIST1 arguments_modifier SEP "," ] +| REPLACE "Implicit" "Type" reserv_list +| WITH "Implicit" [ "Type" | "Types" ] reserv_list +| DELETE "Implicit" "Types" reserv_list + +(* Per @Zimmi48, the global (qualid) must be a simple identifier if def_body is present + Note that smart_global is "qualid | by_notation" and that + ident_decl is "ident OPT univ_decl"; move + *) +| REPLACE "Canonical" OPT "Structure" global OPT [ OPT univ_decl def_body ] +| WITH "Canonical" OPT "Structure" ident_decl def_body +| REPLACE "Canonical" OPT "Structure" by_notation +| WITH "Canonical" OPT "Structure" smart_global + +| REPLACE "Include" "Type" module_type_inl LIST0 ext_module_type +| WITH "Include" "Type" LIST1 module_type_inl SEP "<+" + +| REPLACE "Generalizable" [ "All" "Variables" | "No" "Variables" | [ "Variable" | "Variables" ] LIST1 identref ] +| WITH "Generalizable" [ [ "Variable" | "Variables" ] LIST1 identref | "All" "Variables" | "No" "Variables" ] + +| REPLACE "Export" "Set" option_table option_setting +| WITH OPT "Export" "Set" option_table option_setting +| REPLACE "Export" "Unset" option_table +| WITH OPT "Export" "Unset" option_table +| REPLACE "Instance" instance_name ":" operconstr200 hint_info [ ":=" "{" record_declaration "}" | ":=" lconstr | ] +| WITH "Instance" instance_name ":" operconstr200 hint_info OPT [ ":=" "{" record_declaration "}" | ":=" lconstr ] + ] (* lexer stuff *) @@ -624,6 +665,19 @@ selector_body: [ range_selector_or_nth: [ | DELETENT ] +firstorder_rhs: [ +| firstorder_using +| "with" LIST1 preident +| firstorder_using "with" LIST1 preident +] + +where: [ +| "at" "top" +| "at" "bottom" +| "after" ident +| "before" ident +] + simple_tactic: [ | DELETE "intros" | REPLACE "intros" ne_intropatterns @@ -631,6 +685,158 @@ simple_tactic: [ | DELETE "eintros" | REPLACE "eintros" ne_intropatterns | WITH "eintros" intropatterns +| DELETE "autorewrite" "with" LIST1 preident clause +| DELETE "autorewrite" "with" LIST1 preident clause "using" tactic +| DELETE "autorewrite" "*" "with" LIST1 preident clause +| REPLACE "autorewrite" "*" "with" LIST1 preident clause "using" tactic +| WITH "autorewrite" OPT "*" "with" LIST1 preident clause_dft_concl OPT ( "using" tactic ) +| DELETE "cofix" ident +| REPLACE "cofix" ident "with" LIST1 cofixdecl +| WITH "cofix" ident OPT ( "with" LIST1 cofixdecl ) +| DELETE "constructor" +| DELETE "constructor" int_or_var +| REPLACE "constructor" int_or_var "with" bindings +| WITH "constructor" OPT int_or_var OPT ( "with" bindings ) +| DELETE "econstructor" +| DELETE "econstructor" int_or_var +| REPLACE "econstructor" int_or_var "with" bindings +| WITH "econstructor" OPT ( int_or_var OPT ( "with" bindings ) ) +| DELETE "dependent" "rewrite" orient constr +| REPLACE "dependent" "rewrite" orient constr "in" hyp +| WITH "dependent" "rewrite" orient constr OPT ( "in" hyp ) +| "firstorder" OPT tactic firstorder_rhs +| DELETE "firstorder" OPT tactic firstorder_using +| DELETE "firstorder" OPT tactic "with" LIST1 preident +| DELETE "firstorder" OPT tactic firstorder_using "with" LIST1 preident +| DELETE "fix" ident natural +| REPLACE "fix" ident natural "with" LIST1 fixdecl +| WITH "fix" ident natural OPT ( "with" LIST1 fixdecl ) +| DELETE "generalize" constr +| REPLACE "generalize" constr LIST1 constr +| WITH "generalize" constr OPT ( LIST1 constr ) +| EDIT "simplify_eq" ADD_OPT destruction_arg +| EDIT "esimplify_eq" ADD_OPT destruction_arg +| EDIT "discriminate" ADD_OPT destruction_arg +| EDIT "ediscriminate" ADD_OPT destruction_arg +| DELETE "injection" +| DELETE "injection" destruction_arg +| DELETE "injection" "as" LIST0 simple_intropattern +| REPLACE "injection" destruction_arg "as" LIST0 simple_intropattern +| WITH "injection" OPT destruction_arg OPT ( "as" LIST0 simple_intropattern ) +| DELETE "einjection" +| DELETE "einjection" destruction_arg +| DELETE "einjection" "as" LIST0 simple_intropattern +| REPLACE "einjection" destruction_arg "as" LIST0 simple_intropattern +| WITH "einjection" OPT destruction_arg OPT ( "as" LIST0 simple_intropattern ) +| EDIT "simple" "injection" ADD_OPT destruction_arg +| DELETE "intro" (* todo: change the mlg to simplify! *) +| DELETE "intro" ident +| DELETE "intro" ident "at" "top" +| DELETE "intro" ident "at" "bottom" +| DELETE "intro" ident "after" hyp +| DELETE "intro" ident "before" hyp +| DELETE "intro" "at" "top" +| DELETE "intro" "at" "bottom" +| DELETE "intro" "after" hyp +| DELETE "intro" "before" hyp +| "intro" OPT ident OPT where +| DELETE "move" hyp "at" "top" +| DELETE "move" hyp "at" "bottom" +| DELETE "move" hyp "after" hyp +| DELETE "move" hyp "before" hyp +| "move" ident OPT where +| DELETE "replace" "->" uconstr clause +| DELETE "replace" "<-" uconstr clause +| DELETE "replace" uconstr clause +| "replace" orient uconstr clause_dft_concl (* todo: fix 'clause' *) +| REPLACE "rewrite" "*" orient uconstr "in" hyp "at" occurrences by_arg_tac +| WITH "rewrite" "*" orient uconstr OPT ( "in" hyp ) OPT ( "at" occurrences by_arg_tac ) +| DELETE "rewrite" "*" orient uconstr "in" hyp by_arg_tac +| DELETE "rewrite" "*" orient uconstr "at" occurrences by_arg_tac +| DELETE "rewrite" "*" orient uconstr by_arg_tac +| DELETE "setoid_rewrite" orient glob_constr_with_bindings +| DELETE "setoid_rewrite" orient glob_constr_with_bindings "in" hyp +| DELETE "setoid_rewrite" orient glob_constr_with_bindings "at" occurrences +| REPLACE "setoid_rewrite" orient glob_constr_with_bindings "at" occurrences "in" hyp +| WITH "setoid_rewrite" orient glob_constr_with_bindings OPT ( "at" occurrences ) OPT ( "in" hyp ) +| REPLACE "stepl" constr "by" tactic +| WITH "stepl" constr OPT ( "by" tactic ) +| DELETE "stepl" constr +| REPLACE "stepr" constr "by" tactic +| WITH "stepr" constr OPT ( "by" tactic ) +| DELETE "stepr" constr +| DELETE "unify" constr constr +| REPLACE "unify" constr constr "with" preident +| WITH "unify" constr constr OPT ( "with" preident ) +| DELETE "cutrewrite" orient constr +| REPLACE "cutrewrite" orient constr "in" hyp +| WITH "cutrewrite" orient constr OPT ( "in" hyp ) +| DELETE "destauto" +| REPLACE "destauto" "in" hyp +| WITH "destauto" OPT ( "in" hyp ) +| REPLACE "autounfold_one" hintbases "in" hyp +| WITH "autounfold_one" hintbases OPT ( "in" hyp ) +| DELETE "autounfold_one" hintbases +| REPLACE "rewrite_db" preident "in" hyp +| WITH "rewrite_db" preident OPT ( "in" hyp ) +| DELETE "rewrite_db" preident +| DELETE "setoid_symmetry" +| REPLACE "setoid_symmetry" "in" hyp +| WITH "setoid_symmetry" OPT ( "in" hyp ) +| REPLACE "rewrite_strat" rewstrategy "in" hyp +| WITH "rewrite_strat" rewstrategy OPT ( "in" hyp ) +| DELETE "rewrite_strat" rewstrategy +| REPLACE "protect_fv" string "in" ident +| WITH "protect_fv" string OPT ( "in" ident ) +| DELETE "protect_fv" string +| DELETE "symmetry" +| REPLACE "symmetry" "in" in_clause +| WITH "symmetry" OPT ( "in" in_clause ) +| DELETE "split" +| REPLACE "split" "with" bindings +| WITH "split" OPT ( "with" bindings ) +| DELETE "esplit" +| REPLACE "esplit" "with" bindings +| WITH "esplit" OPT ( "with" bindings ) +| DELETE "specialize" constr_with_bindings +| REPLACE "specialize" constr_with_bindings "as" simple_intropattern +| WITH "specialize" constr_with_bindings OPT ( "as" simple_intropattern ) +| DELETE "exists" +| REPLACE "exists" LIST1 bindings SEP "," +| WITH "exists" OPT ( LIST1 bindings SEP "," ) +| DELETE "eexists" +| REPLACE "eexists" LIST1 bindings SEP "," +| WITH "eexists" OPT ( LIST1 bindings SEP "," ) +| DELETE "left" +| REPLACE "left" "with" bindings +| WITH "left" OPT ( "with" bindings ) +| DELETE "eleft" +| REPLACE "eleft" "with" bindings +| WITH "eleft" OPT ( "with" bindings ) +| DELETE "right" +| REPLACE "right" "with" bindings +| WITH "right" OPT ( "with" bindings ) +| DELETE "eright" +| REPLACE "eright" "with" bindings +| WITH "eright" OPT ( "with" bindings ) +| DELETE "finish_timing" OPT string +| REPLACE "finish_timing" "(" string ")" OPT string +| WITH "finish_timing" OPT ( "(" string ")" ) OPT string +| REPLACE "hresolve_core" "(" ident ":=" constr ")" "at" int_or_var "in" constr +| WITH "hresolve_core" "(" ident ":=" constr ")" OPT ( "at" int_or_var ) "in" constr +| DELETE "hresolve_core" "(" ident ":=" constr ")" "in" constr +| EDIT "psatz_R" ADD_OPT int_or_var tactic +| EDIT "psatz_Q" ADD_OPT int_or_var tactic +| EDIT "psatz_Z" ADD_OPT int_or_var tactic +| REPLACE "subst" LIST1 var +| WITH "subst" OPT ( LIST1 var ) +| DELETE "subst" +| DELETE "congruence" +| DELETE "congruence" int +| DELETE "congruence" "with" LIST1 constr +| REPLACE "congruence" int "with" LIST1 constr +| WITH "congruence" OPT int OPT ( "with" LIST1 constr ) + ] (* todo: don't use DELETENT for this *) @@ -666,6 +872,109 @@ command: [ | WITH "Function" function_rec_definition_loc LIST0 ( "with" function_rec_definition_loc ) (* funind plugin *) | REPLACE "Functional" "Scheme" LIST1 fun_scheme_arg SEP "with" (* funind plugin *) | WITH "Functional" "Scheme" fun_scheme_arg LIST0 ( "with" fun_scheme_arg ) (* funind plugin *) +| DELETE "Cd" +| REPLACE "Cd" ne_string +| WITH "Cd" OPT ne_string +| DELETE "Back" +| REPLACE "Back" natural +| WITH "Back" OPT natural +| REPLACE "Test" option_table "for" LIST1 option_ref_value +| WITH "Test" option_table OPT ( "for" LIST1 option_ref_value ) +| DELETE "Test" option_table +| REPLACE "Load" [ "Verbose" | ] [ ne_string | IDENT ] +| WITH "Load" OPT "Verbose" [ ne_string | IDENT ] +| DELETE "Unset" option_table +| DELETE "Set" option_table option_setting +| REPLACE "Add" IDENT IDENT LIST1 option_ref_value +| WITH "Add" IDENT OPT IDENT LIST1 option_ref_value +| DELETE "Add" IDENT LIST1 option_ref_value +| DELETE "Add" "Parametric" "Relation" binders ":" constr constr "reflexivity" "proved" "by" constr "symmetry" "proved" "by" constr "as" ident +| DELETE "Add" "Parametric" "Relation" binders ":" constr constr "reflexivity" "proved" "by" constr "as" ident +| DELETE "Add" "Parametric" "Relation" binders ":" constr constr "reflexivity" "proved" "by" constr "transitivity" "proved" "by" constr "as" ident +| DELETE "Add" "Parametric" "Relation" binders ":" constr constr "reflexivity" "proved" "by" constr "symmetry" "proved" "by" constr "transitivity" "proved" "by" constr "as" ident +| DELETE "Add" "Parametric" "Relation" binders ":" constr constr "symmetry" "proved" "by" constr "as" ident +| DELETE "Add" "Parametric" "Relation" binders ":" constr constr "symmetry" "proved" "by" constr "transitivity" "proved" "by" constr "as" ident +| DELETE "Add" "Parametric" "Relation" binders ":" constr constr "transitivity" "proved" "by" constr "as" ident +| DELETE "Add" "Parametric" "Relation" binders ":" constr constr "as" ident +| "Add" "Parametric" "Relation" binders ":" constr constr OPT ( "reflexivity" "proved" "by" constr ) OPT ( "symmetry" "proved" "by" constr ) OPT ("transitivity" "proved" "by" constr ) "as" ident +| DELETE "Add" "Relation" constr constr "reflexivity" "proved" "by" constr "symmetry" "proved" "by" constr "as" ident +| DELETE "Add" "Relation" constr constr "reflexivity" "proved" "by" constr "as" ident +| DELETE "Add" "Relation" constr constr "as" ident +| DELETE "Add" "Relation" constr constr "symmetry" "proved" "by" constr "as" ident +| DELETE "Add" "Relation" constr constr "symmetry" "proved" "by" constr "transitivity" "proved" "by" constr "as" ident +| DELETE "Add" "Relation" constr constr "reflexivity" "proved" "by" constr "transitivity" "proved" "by" constr "as" ident +| DELETE "Add" "Relation" constr constr "reflexivity" "proved" "by" constr "symmetry" "proved" "by" constr "transitivity" "proved" "by" constr "as" ident +| DELETE "Add" "Relation" constr constr "transitivity" "proved" "by" constr "as" ident +| "Add" "Relation" constr constr OPT ( "reflexivity" "proved" "by" constr ) OPT ( "symmetry" "proved" "by" constr ) OPT ( "transitivity" "proved" "by" constr ) "as" ident +| REPLACE "Admit" "Obligations" "of" ident +| WITH "Admit" "Obligations" OPT ( "of" ident ) +| DELETE "Admit" "Obligations" +| REPLACE "Create" "HintDb" IDENT; [ "discriminated" | ] +| WITH "Create" "HintDb" IDENT; OPT "discriminated" +| DELETE "Debug" "On" +| REPLACE "Debug" "Off" +| WITH "Debug" [ "On" | "Off" ] +| EDIT "Defined" ADD_OPT identref +| REPLACE "Derive" "Inversion" ident "with" constr "Sort" sort_family +| WITH "Derive" "Inversion" ident "with" constr OPT ( "Sort" sort_family ) +| DELETE "Derive" "Inversion" ident "with" constr +| REPLACE "Derive" "Inversion_clear" ident "with" constr "Sort" sort_family +| WITH "Derive" "Inversion_clear" ident "with" constr OPT ( "Sort" sort_family ) +| DELETE "Derive" "Inversion_clear" ident "with" constr +| EDIT "Focus" ADD_OPT natural +| DELETE "Hint" "Rewrite" orient LIST1 constr ":" LIST0 preident +| REPLACE "Hint" "Rewrite" orient LIST1 constr "using" tactic ":" LIST0 preident +| WITH "Hint" "Rewrite" orient LIST1 constr OPT ( "using" tactic ) OPT ( ":" LIST0 preident ) +| DELETE "Hint" "Rewrite" orient LIST1 constr +| DELETE "Hint" "Rewrite" orient LIST1 constr "using" tactic +| REPLACE "Next" "Obligation" "of" ident withtac +| WITH "Next" "Obligation" OPT ( "of" ident ) withtac +| DELETE "Next" "Obligation" withtac +| REPLACE "Obligation" int "of" ident ":" lglob withtac +| WITH "Obligation" int OPT ( "of" ident ) OPT ( ":" lglob withtac ) +| DELETE "Obligation" int "of" ident withtac +| DELETE "Obligation" int ":" lglob withtac +| DELETE "Obligation" int withtac +| REPLACE "Obligations" "of" ident +| WITH "Obligations" OPT ( "of" ident ) +| DELETE "Obligations" +| REPLACE "Preterm" "of" ident +| WITH "Preterm" OPT ( "of" ident ) +| DELETE "Preterm" +| EDIT "Remove" ADD_OPT IDENT IDENT LIST1 option_ref_value +| DELETE "Restore" "State" IDENT +| DELETE "Restore" "State" ne_string +| "Restore" "State" [ IDENT | ne_string ] +| DELETE "Show" +| DELETE "Show" natural +| DELETE "Show" ident +| "Show" OPT [ ident | natural ] +| DELETE "Show" "Ltac" "Profile" +| REPLACE "Show" "Ltac" "Profile" "CutOff" int +| WITH "Show" "Ltac" "Profile" OPT [ "CutOff" int | string ] +| DELETE "Show" "Ltac" "Profile" string +| DELETE "Show" "Proof" (* combined with Show Proof Diffs in vernac_toplevel *) +| REPLACE "Solve" "All" "Obligations" "with" tactic +| WITH "Solve" "All" "Obligations" OPT ( "with" tactic ) +| DELETE "Solve" "All" "Obligations" +| REPLACE "Solve" "Obligation" int "of" ident "with" tactic +| WITH "Solve" "Obligation" int OPT ( "of" ident ) "with" tactic +| DELETE "Solve" "Obligations" +| DELETE "Solve" "Obligation" int "with" tactic +| REPLACE "Solve" "Obligations" "of" ident "with" tactic +| WITH "Solve" "Obligations" OPT ( OPT ( "of" ident ) "with" tactic ) +| DELETE "Solve" "Obligations" "with" tactic +| DELETE "Undo" +| DELETE "Undo" natural +| REPLACE "Undo" "To" natural +| WITH "Undo" OPT ( OPT "To" natural ) +| DELETE "Write" "State" IDENT +| REPLACE "Write" "State" ne_string +| WITH "Write" "State" [ IDENT | ne_string ] +| DELETE "Abort" +| DELETE "Abort" "All" +| REPLACE "Abort" identref +| WITH "Abort" OPT [ "All" | identref ] ] @@ -737,12 +1046,20 @@ assumption_token: [ | WITH [ "Variable" | "Variables" ] ] -legacy_attrs: [ -| OPT [ "Local" | "Global" ] OPT [ "Polymorphic" | "Monomorphic" ] OPT "Program" OPT [ "Cumulative" | "NonCumulative" ] OPT "Private" +all_attrs: [ +| LIST0 ( "#[" LIST0 attribute SEP "," "]" ) LIST0 legacy_attr ] -all_attrs: [ -| LIST0 ( "#[" LIST0 attribute SEP "," "]" ) OPT legacy_attrs +legacy_attr: [ +| REPLACE "Local" +| WITH [ "Local" | "Global" ] +| DELETE "Global" +| REPLACE "Polymorphic" +| WITH [ "Polymorphic" | "Monomorphic" ] +| DELETE "Monomorphic" +| REPLACE "Cumulative" +| WITH [ "Cumulative" | "NonCumulative" ] +| DELETE "NonCumulative" ] vernacular: [ @@ -770,6 +1087,7 @@ inductive_definition: [ | WITH opt_coercion ident_decl binders OPT [ "|" binders ] OPT [ ":" type ] opt_constructors_or_fields decl_notations ] +(* note that constructor -> identref constructor_type *) constructor_list_or_record_decl: [ | DELETE "|" LIST1 constructor SEP "|" | REPLACE identref constructor_type "|" LIST1 constructor SEP "|" @@ -786,6 +1104,222 @@ record_binder: [ | DELETE name ] +at_level_opt: [ +| OPTINREF +] + +query_command: [ +| REPLACE "Eval" red_expr "in" lconstr "." +| WITH "Eval" red_expr "in" lconstr +| REPLACE "Compute" lconstr "." +| WITH "Compute" lconstr +| REPLACE "Check" lconstr "." +| WITH "Check" lconstr +| REPLACE "About" smart_global OPT univ_name_list "." +| WITH "About" smart_global OPT univ_name_list +| REPLACE "SearchHead" constr_pattern in_or_out_modules "." +| WITH "SearchHead" constr_pattern in_or_out_modules +| REPLACE "SearchPattern" constr_pattern in_or_out_modules "." +| WITH "SearchPattern" constr_pattern in_or_out_modules +| REPLACE "SearchRewrite" constr_pattern in_or_out_modules "." +| WITH "SearchRewrite" constr_pattern in_or_out_modules +| REPLACE "Search" searchabout_query searchabout_queries "." +| WITH "Search" searchabout_query searchabout_queries +] + +vernac_toplevel: [ +(* note these commands can't be referenced by vernac_control commands *) +| REPLACE "Drop" "." +| WITH "Drop" +| REPLACE "Quit" "." +| WITH "Quit" +| REPLACE "BackTo" natural "." +| WITH "BackTo" natural +| REPLACE "Show" "Goal" natural "at" natural "." +| WITH "Show" "Goal" natural "at" natural +| REPLACE "Show" "Proof" "Diffs" OPT "removed" "." +| WITH "Show" "Proof" OPT ( "Diffs" OPT "removed" ) +| DELETE vernac_control +] + +positive_search_mark: [ +| OPTINREF +] + +in_or_out_modules: [ +| OPTINREF +] + +searchabout_queries: [ +| OPTINREF +] + +vernac_control: [ +(* replacing vernac_control with command is cheating a little; + they can't refer to the vernac_toplevel commands. + cover this the descriptions of these commands *) +| REPLACE "Time" vernac_control +| WITH "Time" command +| REPLACE "Redirect" ne_string vernac_control +| WITH "Redirect" ne_string command +| REPLACE "Timeout" natural vernac_control +| WITH "Timeout" natural command +| REPLACE "Fail" vernac_control +| WITH "Fail" command +| DELETE decorated_vernac +] + +option_setting: [ +| OPTINREF +] + +orient: [ +| OPTINREF +] + +in_hyp_as: [ +| OPTINREF +] + +as_name: [ +| OPTINREF +] + +hloc: [ +| OPTINREF +] + +as_or_and_ipat: [ +| OPTINREF +] + +hintbases: [ +| OPTINREF +] + +as_ipat: [ +| OPTINREF +] + +auto_using: [ +| OPTINREF +] + +with_bindings: [ +| OPTINREF +] + +eqn_ipat: [ +| OPTINREF +] + +withtac: [ +| OPTINREF +] + +of_module_type: [ +| (* empty *) +| OPTINREF +] + + +clause_dft_all: [ +| OPTINREF +] + +opt_clause: [ +| OPTINREF +] + +with_names: [ +| OPTINREF +] + +in_hyp_list: [ +| OPTINREF +] + +struct_annot: [ +| OPTINREF +] + +firstorder_using: [ +| OPTINREF +] + +fun_ind_using: [ +| OPTINREF +] + +by_arg_tac: [ +| OPTINREF +] + +by_tactic: [ +| OPTINREF +] + +rewriter: [ +| REPLACE [ "?" | LEFTQMARK ] constr_with_bindings_arg +| WITH "?" constr_with_bindings_arg +] + +intropattern_or_list_or: [ +(* todo: where does intropattern_or_list_or come from?? *) +| REPLACE intropattern_or_list_or "|" intropatterns +| WITH LIST0 intropattern LIST0 ( "|" intropatterns ) +| DELETE intropatterns +] + +record_declaration: [ +| DELETE fields_def +| LIST0 field_def +] + +fields_def: [ | DELETENT ] + +hint_info: [ +| OPTINREF +] + +debug: [ +| OPTINREF +] + +eauto_search_strategy: [ +| OPTINREF +] + + +constr_body: [ +| DELETE ":=" lconstr +| REPLACE ":" lconstr ":=" lconstr +| WITH OPT ( ":" lconstr ) ":=" lconstr +] + +opt_hintbases: [ +| OPTINREF +] + +opthints: [ +| OPTINREF +] + +scheme: [ +| DELETE scheme_kind +| REPLACE identref ":=" scheme_kind +| WITH OPT ( identref ":=" ) scheme_kind +] + +instance_name: [ +| OPTINREF +] + +simple_reserv: [ +| REPLACE LIST1 identref ":" lconstr +| WITH LIST1 identref ":" type +] + in_clause: [ | DELETE in_clause' | REPLACE LIST0 hypident_occ SEP "," "|-" concl_occ @@ -811,9 +1345,14 @@ decl_notations: [ | OPTINREF ] +module_expr: [ +| REPLACE module_expr_atom +| WITH LIST1 module_expr_atom +| DELETE module_expr module_expr_atom +] + SPLICE: [ | noedit_mode -| command_entry | bigint | match_list | match_context_list @@ -842,7 +1381,6 @@ SPLICE: [ | ne_lstring | ne_string | lstring -| basequalid | fullyqualid | global | reference @@ -918,7 +1456,6 @@ SPLICE: [ | binders_fixannot | as_return_type | case_type -| fields_def | universe_increment | type_cstr | record_pattern @@ -945,8 +1482,42 @@ SPLICE: [ | record_fields | constructor_type | record_binder +| at_level_opt +| option_ref_value +| positive_search_mark +| in_or_out_modules +| register_prim_token +| option_setting +| orient +| with_bindings +| by_arg_tac +| by_tactic +| quantified_hypothesis +| nat_or_var +| in_hyp_list +| rename +| export_token +| reserv_tuple +| inst | opt_coercion | opt_constructors_or_fields +| is_module_type +| is_module_expr +| module_expr +| mlname +| withtac +| debug +| eauto_search_strategy +| constr_body +| reference_or_constr +| opt_hintbases +| hints_path_atom +| opthints +| scheme +| fresh_id +| ltac_def_kind +| intropatterns +| instance_name ] (* end SPLICE *) RENAME: [ @@ -963,7 +1534,6 @@ RENAME: [ | tactic_expr0 ltac_expr0 (* | nonsimple_intropattern intropattern (* ltac2 *) *) -| intropatterns intropattern_list_opt | operconstr200 term (* historical name *) | operconstr100 term100 @@ -982,14 +1552,12 @@ RENAME: [ | match_hyps match_hyp | BULLET bullet -| nat_or_var num_or_var | fix_decl fix_body | cofix_decl cofix_body | constr one_term | appl_arg arg | rec_definition fix_definition | corec_definition cofix_definition -| inst evar_binding | univ_instance univ_annot | simple_assum_coe assumpt | of_type_with_opt_coercion of_type @@ -1001,5 +1569,90 @@ RENAME: [ | smart_global smart_qualid ] +(* todo: doesn't work if up above... maybe because 'clause' doesn't exist? *) +clause_dft_concl: [ +| OPTINREF +] + +(* add in ltac and Tactic Notation tactics that appear in the doc: *) +ltac_defined_tactics: [ +| "classical_left" +| "classical_right" +| "contradict" ident +| "discrR" +| "easy" +| "exfalso" +| "inversion_sigma" +| "lia" +| "lra" +| "nia" +| "nra" +| "split_Rabs" +| "split_Rmult" +| "tauto" +| "zify" +] + +(* todo: need careful review; assume that "[" ... "]" are literals *) +tactic_notation_tactics: [ +| "assert_fails" ltac_expr3 +| "assert_succeeds" ltac_expr3 +| "field" OPT ( "[" LIST1 term "]" ) +| "field_simplify" OPT ( "[" LIST1 term "]" ) LIST1 term OPT ( "in" ident ) +| "field_simplify_eq" OPT ( "[" LIST1 term "]" ) OPT ( "in" ident ) +| "intuition" OPT ltac_expr +| "nsatz" OPT ( "with" "radicalmax" ":=" term "strategy" ":=" term "parameters" ":=" term "variables" ":=" term ) +| "psatz" term OPT int_or_var +| "ring" OPT ( "[" LIST1 term "]" ) +| "ring_simplify" OPT ( "[" LIST1 term "]" ) LIST1 term OPT ( "in" ident ) (* todo: ident was "hyp", worth keeping? *) +] + +tacticals: [ +] + +simple_tactic: [ +| ltac_defined_tactics +| tactic_notation_tactics +] + +(* move all commands under "command" *) + +DELETE: [ +| vernac +] + +tactic_mode: [ +(* todo: make sure to document this production! *) +(* deleting to allow splicing query_command into command *) +| DELETE OPT toplevel_selector query_command +] +vernac_aux: [ +| DELETE gallina "." +| DELETE gallina_ext "." +| DELETE syntax "." +| DELETE command_entry +] + +command: [ +| gallina +| gallina_ext +| syntax +| query_command +| vernac_control +| vernac_toplevel +| command_entry +] + +SPLICE: [ +| gallina +| gallina_ext +| syntax +| query_command +| vernac_control +| vernac_toplevel +| command_entry +| ltac_defined_tactics +| tactic_notation_tactics +] (* todo: ssrreflect*.rst ref to fix_body is incorrect *) diff --git a/doc/tools/docgram/doc_grammar.ml b/doc/tools/docgram/doc_grammar.ml index 5c9a13668f..eea1d5081d 100644 --- a/doc/tools/docgram/doc_grammar.ml +++ b/doc/tools/docgram/doc_grammar.ml @@ -32,6 +32,7 @@ type args = { fullGrammar : bool; check_tacs : bool; check_cmds : bool; + no_update: bool; show_warn : bool; verbose : bool; verify : bool; @@ -43,12 +44,13 @@ let default_args = { fullGrammar = false; check_tacs = false; check_cmds = false; + no_update = false; show_warn = true; verbose = false; verify = false; } -let start_symbols = ["vernac_toplevel"] +let start_symbols = ["vernacular"] let tokens = [ "bullet"; "string"; "unicode_id_part"; "unicode_letter" ] (* translated symbols *) @@ -1165,7 +1167,7 @@ let apply_edit_file g edits = in aux tl prods' add_nt | (Snterm "OPTINREF" :: _) :: tl -> - if not (List.mem [] prods) then + if not (has_match [] prods) then error "OPTINREF but no empty production for %s\n" nt; global_repl g [(Snterm nt)] [(Sopt (Snterm nt))]; aux tl (remove_prod [] prods nt) add_nt @@ -1574,7 +1576,7 @@ let reorder_grammar eg reordered_rules file = g_reorder eg !og.map !og.order -let finish_with_file old_file verify = +let finish_with_file old_file args = let files_eq f1 f2 = let chunksize = 8192 in (try @@ -1605,21 +1607,24 @@ let finish_with_file old_file verify = with Sys_error _ -> false) in - let temp_file = (old_file ^ "_temp") in + let temp_file = (old_file ^ ".new") in if !exit_code <> 0 then Sys.remove temp_file - else if verify then begin + else if args.verify then begin if not (files_eq old_file temp_file) then error "%s is not current\n" old_file; Sys.remove temp_file - end else + end else if not args.no_update then Sys.rename temp_file old_file let open_temp_bin file = - open_out_bin (sprintf "%s_temp" file) + open_out_bin (sprintf "%s.new" file) + +let match_cmd_regex = Str.regexp "[a-zA-Z0-9_ ]+" let find_longest_match prods str = - (* todo: require a minimum length? *) + let get_pfx str = String.trim (if Str.string_match match_cmd_regex str 0 then Str.matched_string str else "") in + let prods = StringSet.fold (fun a lst -> a :: lst) prods [] in (* todo: wasteful! *) let common_prefix_len s1 s2 = let limit = min (String.length s1) (String.length s2) in let rec aux off = @@ -1631,13 +1636,16 @@ let find_longest_match prods str = in let slen = String.length str in + let str_pfx = get_pfx str in let rec longest best multi best_len prods = match prods with | [] -> best, multi, best_len | prod :: tl -> - let pstr = String.trim (prod_to_prodn prod) in + let pstr = String.trim prod in (* todo: should be pretrimmed *) let clen = common_prefix_len str pstr in - if clen = slen && slen = String.length pstr then + if str_pfx = "" || str_pfx <> get_pfx pstr then + longest best multi best_len tl (* prefixes don't match *) + else if clen = slen && slen = String.length pstr then pstr, false, clen (* exact match *) else if clen > best_len then longest pstr false clen tl (* better match *) @@ -1651,6 +1659,7 @@ let find_longest_match prods str = type seen = { nts: (string * int) NTMap.t; tacs: (string * int) NTMap.t; + tacvs: (string * int) NTMap.t; cmds: (string * int) NTMap.t; cmdvs: (string * int) NTMap.t; } @@ -1659,8 +1668,9 @@ let process_rst g file args seen tac_prods cmd_prods = let old_rst = open_in file in let new_rst = open_temp_bin file in let linenum = ref 0 in - let dir_regex = Str.regexp "^\\([ \t]*\\)\\.\\.[ \t]*\\([a-zA-Z0-9:]*\\)\\(.*\\)" in - let ig_args_regex = Str.regexp "^[ \t]*\\([a-zA-Z0-9_\\.]*\\)[ \t]*\\([a-zA-Z0-9_\\.]*\\)" in + let dir_regex = Str.regexp "^\\([ \t]*\\)\\.\\.[ \t]*\\([a-zA-Z0-9:]* *\\)\\(.*\\)" in + let contin_regex = Str.regexp "^\\([ \t]*\\)\\(.*\\)" in + let ip_args_regex = Str.regexp "^[ \t]*\\([a-zA-Z0-9_\\.]*\\)[ \t]*\\([a-zA-Z0-9_\\.]*\\)" in let blank_regex = Str.regexp "^[ \t]*$" in let end_prodlist_regex = Str.regexp "^[ \t]*$" in let getline () = @@ -1692,7 +1702,7 @@ let process_rst g file args seen tac_prods cmd_prods = in let process_insertprodn line rhs = - if not (Str.string_match ig_args_regex rhs 0) then + if not (Str.string_match ip_args_regex rhs 0) then error "%s line %d: bad arguments '%s' for 'insertprodn'\n" file !linenum rhs else begin let start = Str.matched_group 1 rhs in @@ -1703,8 +1713,8 @@ let process_rst g file args seen tac_prods cmd_prods = error "%s line %d: '%s' is undefined in insertprodn\n" file !linenum start; if end_index = None then error "%s line %d: '%s' is undefined in insertprodn\n" file !linenum end_; - if start_index <> None && end_index <> None then - check_range_consistency g start end_; +(* if start_index <> None && end_index <> None then*) +(* check_range_consistency g start end_;*) match start_index, end_index with | Some start_index, Some end_index -> if start_index > end_index then @@ -1716,7 +1726,7 @@ let process_rst g file args seen tac_prods cmd_prods = error "%s line %d: expecting a blank line after 'insertprodn'\n" file !linenum else begin let line3 = getline() in - if not (Str.string_match dir_regex line3 0) || (Str.matched_group 2 line3) <> "prodn::" then + if not (Str.string_match dir_regex line3 0) || (String.trim (Str.matched_group 2 line3)) <> "prodn::" then error "%s line %d: expecting '.. prodn::' after 'insertprodn'\n" file !linenum else begin let indent = Str.matched_group 1 line3 in @@ -1736,38 +1746,82 @@ let process_rst g file args seen tac_prods cmd_prods = end | _ -> () end + in + +(* let skip_files = ["doc/sphinx/proof-engine/ltac.rst"; "doc/sphinx/proof-engine/ltac2.rst";*) +(* "doc/sphinx/proof-engine/ssreflect-proof-language.rst"]*) +(* in*) + let cmd_replace_files = [ + "doc/sphinx/language/gallina-specification-language.rst"; + "doc/sphinx/language/gallina-extensions.rst" + ] in + + let save_n_get_more direc pfx first_rhs seen_map prods = + let replace rhs prods = + if StringSet.is_empty prods || not (List.mem file cmd_replace_files) then + rhs (* no change *) + else + let mtch, multi, len = find_longest_match prods rhs in + if mtch = rhs then + rhs (* no change *) + else if mtch = "" then begin + warn "%s line %d: NO MATCH `%s`\n" file !linenum rhs; + rhs + end else if multi then begin + warn "%s line %d: MULTIMATCH `%s`\n" file !linenum rhs; + rhs + end else + mtch (* update cmd/tacn *) + in + let map = ref seen_map in + if NTMap.mem first_rhs !map then + warn "%s line %d: Repeated %s: '%s'\n" file !linenum direc first_rhs; +(* if not (StringSet.mem rhs seen_map) then*) +(* warn "%s line %d: Unknown tactic: '%s'\n" file !linenum rhs;*) + + fprintf new_rst "%s%s\n" pfx (replace first_rhs prods); + + map := NTMap.add first_rhs (file, !linenum) !map; + while + let nextline = getline() in + ignore (Str.string_match contin_regex nextline 0); + let indent = Str.matched_group 1 nextline in + let rhs = Str.matched_group 2 nextline in + let replaceable = rhs <> "" && rhs.[0] <> ':' in + let upd_rhs = if replaceable then (replace rhs prods) else rhs in + fprintf new_rst "%s%s\n" indent upd_rhs; + if replaceable then begin + map := NTMap.add rhs (file, !linenum) !map + end; + rhs <> "" + do + () + done; + !map + in + try while true do let line = getline() in if Str.string_match dir_regex line 0 then begin - let dir = Str.matched_group 2 line in - let rhs = String.trim (Str.matched_group 3 line) in + let dir = String.trim (Str.matched_group 2 line) in + let rhs = Str.matched_group 3 line in + let pfx = String.sub line 0 (Str.group_end 2) in match dir with | "prodn::" -> if rhs = "coq" then warn "%s line %d: Missing 'insertprodn' before 'prodn:: coq'\n" file !linenum; fprintf new_rst "%s\n" line; | "tacn::" when args.check_tacs -> - if not (StringSet.mem rhs tac_prods) then - warn "%s line %d: Unknown tactic: '%s'\n" file !linenum rhs; - if NTMap.mem rhs !seen.tacs then - warn "%s line %d: Repeated tactic: '%s'\n" file !linenum rhs; - seen := { !seen with tacs = (NTMap.add rhs (file, !linenum) !seen.tacs)}; - fprintf new_rst "%s\n" line + seen := { !seen with tacs = save_n_get_more "tacn" pfx rhs !seen.tacs tac_prods } + | "tacv::" when args.check_tacs -> + seen := { !seen with tacvs = save_n_get_more "tacv" pfx rhs !seen.tacvs StringSet.empty } | "cmd::" when args.check_cmds -> -(* - if not (StringSet.mem rhs cmd_prods) then - warn "%s line %d: Unknown command: '%s'\n" file !linenum rhs; - if NTMap.mem rhs !seen.cmds then - warn "%s line %d: Repeated command: '%s'\n" file !linenum rhs; -*) - seen := { !seen with cmds = (NTMap.add rhs (file, !linenum) !seen.cmds)}; - fprintf new_rst "%s\n" line + seen := { !seen with cmds = save_n_get_more "cmd" pfx rhs !seen.cmds cmd_prods } | "cmdv::" when args.check_cmds -> - seen := { !seen with cmdvs = (NTMap.add rhs (file, !linenum) !seen.cmdvs)}; - fprintf new_rst "%s\n" line + seen := { !seen with cmdvs = save_n_get_more "cmdv" pfx rhs !seen.cmdvs StringSet.empty } | "insertprodn" -> process_insertprodn line rhs | _ -> fprintf new_rst "%s\n" line @@ -1777,7 +1831,7 @@ let process_rst g file args seen tac_prods cmd_prods = with End_of_file -> (); close_in old_rst; close_out new_rst; - finish_with_file file args.verify + finish_with_file file args let report_omitted_prods entries seen label split = let maybe_warn first last n = @@ -1825,7 +1879,7 @@ let process_grammar args = "DOC_GRAMMAR"; print_in_order out g `MLG !g.order StringSet.empty; close_out out; - finish_with_file (dir "fullGrammar") args.verify; + finish_with_file (dir "fullGrammar") args; if args.verbose then print_special_tokens g; @@ -1835,19 +1889,7 @@ let process_grammar args = let common_edits = read_mlg_edit "common.edit_mlg" in apply_edit_file g common_edits end; - let prodn_gram = ref { map = !g.map; order = !g.order } in - - if !exit_code = 0 && not args.verify then begin - let prodlist_edits = read_mlg_edit "productionlist.edit_mlg" in - apply_edit_file g prodlist_edits; - let out = open_temp_bin (dir "productionlistGrammar") in - if args.verbose then - report_info g !symdef_map; - print_in_order out g `PRODLIST !g.order StringSet.empty; - (*print_chunks g out `PRODLIST ();*) - close_out out; - finish_with_file (dir "productionlistGrammar") args.verify; - end; + let prodn_gram = ref { map = !g.map; order = !g.order } in (* todo: should just be 'g', right? *) if !exit_code = 0 && not args.verify then begin let out = open_temp_bin (dir "editedGrammar") in @@ -1856,7 +1898,7 @@ let process_grammar args = "DOC_GRAMMAR"; print_in_order out g `MLG !g.order StringSet.empty; close_out out; - finish_with_file (dir "editedGrammar") args.verify; + finish_with_file (dir "editedGrammar") args; report_bad_nts g "editedGrammar" end; @@ -1864,18 +1906,20 @@ let process_grammar args = let ordered_grammar = read_mlg_edit "orderedGrammar" in let out = open_temp_bin (dir "orderedGrammar") in fprintf out "%s\n%s\n\n" - ("(* Defines the order to apply to editedGrammar to get productionlistGrammar.\n" ^ + ("(* Defines the order to apply to editedGrammar to get the final grammar for the doc.\n" ^ "doc_grammar will modify this file to add/remove nonterminals and productions\n" ^ "to match editedGrammar, which will remove comments. Not compiled into Coq *)") "DOC_GRAMMAR"; reorder_grammar g ordered_grammar "orderedGrammar"; print_in_order out g `MLG !g.order StringSet.empty; close_out out; - finish_with_file (dir "orderedGrammar") args.verify; + finish_with_file (dir "orderedGrammar") args; check_singletons g (* print_dominated g*) end; + let seen = ref { nts=NTMap.empty; tacs=NTMap.empty; tacvs=NTMap.empty; cmds=NTMap.empty; cmdvs=NTMap.empty } in + let args = { args with no_update = false } in (* always update rsts in place for now *) if !exit_code = 0 then begin let plist nt = let list = (List.map (fun t -> String.trim (prod_to_prodn t)) @@ -1883,11 +1927,12 @@ let process_grammar args = list, StringSet.of_list list in let tac_list, tac_prods = plist "simple_tactic" in let cmd_list, cmd_prods = plist "command" in - let seen = ref { nts=NTMap.empty; tacs=NTMap.empty; cmds=NTMap.empty; cmdvs=NTMap.empty } in List.iter (fun file -> process_rst g file args seen tac_prods cmd_prods) args.rst_files; report_omitted_prods !g.order !seen.nts "Nonterminal" ""; let out = open_out (dir "updated_rsts") in close_out out; + end; + (* if args.check_tacs then report_omitted_prods tac_list !seen.tacs "Tactic" "\n "; @@ -1895,41 +1940,48 @@ let process_grammar args = report_omitted_prods cmd_list !seen.cmds "Command" "\n "; *) - let rstCmds = StringSet.of_list (List.map (fun b -> let c, _ = b in c) (NTMap.bindings !seen.cmds)) in - let rstCmdvs = StringSet.of_list (List.map (fun b -> let c, _ = b in c) (NTMap.bindings !seen.cmdvs)) in - let command_nts = ["command"; "gallina"; "gallina_ext"; "query_command"; "syntax"] in + if !exit_code = 0 then begin + (* generate report on cmds or tacs *) + let cmdReport outfile cmdStr cmd_nts cmds cmdvs = + let rstCmds = StringSet.of_list (List.map (fun b -> let c, _ = b in c) (NTMap.bindings cmds)) in + let rstCmdvs = StringSet.of_list (List.map (fun b -> let c, _ = b in c) (NTMap.bindings cmdvs)) in + let gramCmds = List.fold_left (fun set nt -> + StringSet.union set (StringSet.of_list (List.map (fun p -> String.trim (prod_to_prodn p)) (NTMap.find nt !prodn_gram.map))) + ) StringSet.empty cmd_nts in + let allCmds = StringSet.union rstCmdvs (StringSet.union rstCmds gramCmds) in + let out = open_temp_bin (dir outfile) in + StringSet.iter (fun c -> + let rsts = StringSet.mem c rstCmds in + let gram = StringSet.mem c gramCmds in + let pfx = match rsts, gram with + | true, false -> "+" + | false, true -> "-" + | false, false -> "?" + | _, _ -> " " + in + let var = if StringSet.mem c rstCmdvs then "v" else " " in + fprintf out "%s%s %s\n" pfx var c) + allCmds; + close_out out; + finish_with_file (dir outfile) args; + Printf.printf "# %s in rsts, gram, total = %d %d %d\n" cmdStr (StringSet.cardinal gramCmds) + (StringSet.cardinal rstCmds) (StringSet.cardinal allCmds); + in + + let cmd_nts = ["command"] in (* TODO: need to handle tactic_mode (overlaps with query_command) and subprf *) - let gramCmds = List.fold_left (fun set nt -> - StringSet.union set (StringSet.of_list (List.map (fun p -> String.trim (prod_to_prodn p)) (NTMap.find nt !prodn_gram.map))) - ) StringSet.empty command_nts in - - let allCmds = StringSet.union rstCmdvs (StringSet.union rstCmds gramCmds) in - let out = open_out_bin (dir "prodnCommands") in - StringSet.iter (fun c -> - let rsts = StringSet.mem c rstCmds in - let gram = StringSet.mem c gramCmds in - let pfx = match rsts, gram with - | true, false -> "+" - | false, true -> "-" - | false, false -> "?" - | _, _ -> " " - in - let var = if StringSet.mem c rstCmdvs then "v" else " " in - fprintf out "%s%s %s\n" pfx var c) - allCmds; - close_out out; - Printf.printf "# cmds in rsts, gram, total = %d %d %d\n" (StringSet.cardinal gramCmds) - (StringSet.cardinal rstCmds) (StringSet.cardinal allCmds); + cmdReport "prodnCommands" "cmds" cmd_nts !seen.cmds !seen.cmdvs; + + let tac_nts = ["simple_tactic"] in + cmdReport "prodnTactics" "tacs" tac_nts !seen.tacs !seen.tacvs end; - (* generate output for prodn: simple_tactic, command, also for Ltac?? *) + (* generate prodnGrammar for reference *) if !exit_code = 0 && not args.verify then begin - let prodn_edits = read_mlg_edit "prodn.edit_mlg" in - apply_edit_file prodn_gram prodn_edits; let out = open_temp_bin (dir "prodnGrammar") in print_in_order out prodn_gram `PRODN !prodn_gram.order StringSet.empty; close_out out; - finish_with_file (dir "prodnGrammar") args.verify + finish_with_file (dir "prodnGrammar") args end end @@ -1941,6 +1993,7 @@ let parse_args () = | "-check-cmds" -> { args with check_cmds = true } | "-check-tacs" -> { args with check_tacs = true } | "-no-warn" -> show_warn := false; { args with show_warn = true } + | "-no-update" -> { args with no_update = true } | "-short" -> { args with fullGrammar = true } | "-verbose" -> { args with verbose = true } | "-verify" -> { args with verify = true } diff --git a/doc/tools/docgram/dune b/doc/tools/docgram/dune index 3afa21f2cf..fba4856241 100644 --- a/doc/tools/docgram/dune +++ b/doc/tools/docgram/dune @@ -5,26 +5,47 @@ (env (_ (binaries doc_grammar.exe))) (rule - (targets fullGrammar) + (alias check-gram) (deps - ; Main grammar - (glob_files %{project_root}/parsing/*.mlg) - (glob_files %{project_root}/toplevel/*.mlg) - (glob_files %{project_root}/vernac/*.mlg) - ; All plugins except SSReflect for now (mimicking what is done in Makefile.doc) - (glob_files %{project_root}/plugins/btauto/*.mlg) - (glob_files %{project_root}/plugins/cc/*.mlg) - (glob_files %{project_root}/plugins/derive/*.mlg) - (glob_files %{project_root}/plugins/extraction/*.mlg) - (glob_files %{project_root}/plugins/firstorder/*.mlg) - (glob_files %{project_root}/plugins/funind/*.mlg) - (glob_files %{project_root}/plugins/ltac/*.mlg) - (glob_files %{project_root}/plugins/micromega/*.mlg) - (glob_files %{project_root}/plugins/nsatz/*.mlg) - (glob_files %{project_root}/plugins/omega/*.mlg) - (glob_files %{project_root}/plugins/rtauto/*.mlg) - (glob_files %{project_root}/plugins/setoid_ring/*.mlg) - (glob_files %{project_root}/plugins/syntax/*.mlg)) + (:input + ; Main grammar + (glob_files %{project_root}/parsing/*.mlg) + (glob_files %{project_root}/toplevel/*.mlg) + (glob_files %{project_root}/vernac/*.mlg) + ; All plugins except SSReflect and Ltac2 for now (mimicking what is done in Makefile.doc) + (glob_files %{project_root}/plugins/btauto/*.mlg) + (glob_files %{project_root}/plugins/cc/*.mlg) + (glob_files %{project_root}/plugins/derive/*.mlg) + (glob_files %{project_root}/plugins/extraction/*.mlg) + (glob_files %{project_root}/plugins/firstorder/*.mlg) + (glob_files %{project_root}/plugins/funind/*.mlg) + (glob_files %{project_root}/plugins/ltac/*.mlg) + (glob_files %{project_root}/plugins/micromega/*.mlg) + (glob_files %{project_root}/plugins/nsatz/*.mlg) + (glob_files %{project_root}/plugins/omega/*.mlg) + (glob_files %{project_root}/plugins/rtauto/*.mlg) + (glob_files %{project_root}/plugins/setoid_ring/*.mlg) + (glob_files %{project_root}/plugins/syntax/*.mlg) + ; Sphinx files + (glob_files %{project_root}/doc/sphinx/language/*.rst) + (glob_files %{project_root}/doc/sphinx/proof-engine/*.rst) + (glob_files %{project_root}/doc/sphinx/user-extensions/*.rst) + (glob_files %{project_root}/doc/sphinx/practical-tools/*.rst) + (glob_files %{project_root}/doc/sphinx/addendum/*.rst) + (glob_files %{project_root}/doc/sphinx/language/core/*.rst) + (glob_files %{project_root}/doc/sphinx/language/extensions/*.rst) + (glob_files %{project_root}/doc/sphinx/proofs/writing-proofs/*.rst) + (glob_files %{project_root}/doc/sphinx/proofs/automatic-tactics/*.rst) + (glob_files %{project_root}/doc/sphinx/proofs/creating-tactics/*.rst) + (glob_files %{project_root}/doc/sphinx/using/libraries/*.rst) + (glob_files %{project_root}/doc/sphinx/using/tools/*.rst)) + common.edit_mlg + orderedGrammar) (action - (chdir %{project_root} (run doc_grammar -short -no-warn %{deps}))) - (mode promote)) + (progn + (bash "for f in fullGrammar orderedGrammar; do cp ${f} ${f}.old; done") + (chdir %{project_root} (run doc_grammar -check-cmds %{input})) + (bash "for f in fullGrammar orderedGrammar; do cp ${f} ${f}.new; done") + (bash "for f in fullGrammar orderedGrammar; do cp ${f}.old ${f}; done") + (diff? fullGrammar fullGrammar.new) + (diff? orderedGrammar orderedGrammar.new)))) diff --git a/doc/tools/docgram/fullGrammar b/doc/tools/docgram/fullGrammar index 6897437457..272d17bb35 100644 --- a/doc/tools/docgram/fullGrammar +++ b/doc/tools/docgram/fullGrammar @@ -386,11 +386,6 @@ fullyqualid: [ | ident ] -basequalid: [ -| ident fields -| ident -] - name: [ | "_" | ident @@ -401,6 +396,10 @@ reference: [ | ident ] +qualid: [ +| reference +] + by_notation: [ | ne_string OPT [ "%" IDENT ] ] @@ -410,10 +409,6 @@ smart_global: [ | by_notation ] -qualid: [ -| basequalid -] - ne_string: [ | STRING ] @@ -435,17 +430,21 @@ lstring: [ ] integer: [ -| NUMERAL -| "-" NUMERAL +| bigint ] natural: [ -| NUMERAL +| bignat | _natural ] bigint: [ | NUMERAL +| test_minus_nat "-" NUMERAL +] + +bignat: [ +| NUMERAL ] bar_cbrace: [ @@ -735,21 +734,22 @@ attribute_value: [ | ] -vernac: [ -| "Local" vernac_poly -| "Global" vernac_poly -| vernac_poly +legacy_attr: [ +| "Local" +| "Global" +| "Polymorphic" +| "Monomorphic" +| "Cumulative" +| "NonCumulative" +| "Private" +| "Program" ] -vernac_poly: [ -| "Polymorphic" vernac_aux -| "Monomorphic" vernac_aux -| vernac_aux +vernac: [ +| LIST0 legacy_attr vernac_aux ] vernac_aux: [ -| "Program" gallina "." -| "Program" gallina_ext "." | gallina "." | gallina_ext "." | command "." @@ -774,7 +774,7 @@ gallina: [ | assumptions_token inline assum_list | def_token ident_decl def_body | "Let" identref def_body -| OPT cumulativity_token private_token finite_token LIST1 inductive_definition SEP "with" +| finite_token LIST1 inductive_definition SEP "with" | "Fixpoint" LIST1 rec_definition SEP "with" | "Let" "Fixpoint" LIST1 rec_definition SEP "with" | "CoFixpoint" LIST1 corec_definition SEP "with" @@ -903,16 +903,6 @@ finite_token: [ | "Class" ] -cumulativity_token: [ -| "Cumulative" -| "NonCumulative" -] - -private_token: [ -| "Private" -| -] - def_body: [ | binders ":=" reduce lconstr | binders ":" lconstr ":=" reduce lconstr @@ -1254,8 +1244,6 @@ query_command: [ | "SearchPattern" constr_pattern in_or_out_modules "." | "SearchRewrite" constr_pattern in_or_out_modules "." | "Search" searchabout_query searchabout_queries "." -| "SearchAbout" searchabout_query searchabout_queries "." -| "SearchAbout" "[" LIST1 searchabout_query "]" in_or_out_modules "." ] printable: [ @@ -2464,8 +2452,6 @@ as_or_and_ipat: [ eqn_ipat: [ | "eqn" ":" naming_intropattern -| "_eqn" ":" naming_intropattern -| "_eqn" | ] @@ -2530,7 +2516,7 @@ field_mods: [ numnotoption: [ | -| "(" "warning" "after" bigint ")" -| "(" "abstract" "after" bigint ")" +| "(" "warning" "after" bignat ")" +| "(" "abstract" "after" bignat ")" ] diff --git a/doc/tools/docgram/orderedGrammar b/doc/tools/docgram/orderedGrammar index f26a174722..0c9d7a853b 100644 --- a/doc/tools/docgram/orderedGrammar +++ b/doc/tools/docgram/orderedGrammar @@ -1,19 +1,9 @@ -(* Defines the order to apply to editedGrammar to get productionlistGrammar. +(* Defines the order to apply to editedGrammar to get the final grammar for the doc. doc_grammar will modify this file to add/remove nonterminals and productions to match editedGrammar, which will remove comments. Not compiled into Coq *) DOC_GRAMMAR -vernac_toplevel: [ -| "Drop" "." -| "Quit" "." -| "BackTo" num "." -| "Show" "Goal" num "at" num "." -| "Show" "Proof" "Diffs" OPT "removed" "." -| vernac_control -] - tactic_mode: [ -| OPT toplevel_selector query_command | OPT toplevel_selector "{" | OPT toplevel_selector OPT ( "Info" num ) ltac_expr ltac_use_default | "par" ":" OPT ( "Info" num ) ltac_expr ltac_use_default @@ -24,14 +14,6 @@ ltac_use_default: [ | "..." ] -vernac_control: [ -| "Time" vernac_control -| "Redirect" string vernac_control -| "Timeout" num vernac_control -| "Fail" vernac_control -| LIST0 ( "#[" LIST0 attr SEP "," "]" ) vernac -] - term: [ | "forall" open_binders "," term | "fun" open_binders "=>" term @@ -96,11 +78,7 @@ term_projection: [ term_evar: [ | "?[" ident "]" | "?[" "?" ident "]" -| "?" ident OPT ( "@{" LIST1 evar_binding SEP ";" "}" ) -] - -evar_binding: [ -| ident ":=" term +| "?" ident OPT ( "@{" LIST1 ( ident ":=" term ) SEP ";" "}" ) ] dangling_pattern_extension_rule: [ @@ -167,12 +145,28 @@ subsequent_letter: [ | [ first_letter | digit | "'" | unicode_id_part ] ] +firstorder_rhs: [ +| OPT firstorder_using +| "with" LIST1 ident +| OPT firstorder_using "with" LIST1 ident +] + +where: [ +| "at" "top" +| "at" "bottom" +| "after" ident +| "before" ident +] + vernacular: [ | LIST0 ( OPT all_attrs [ command | ltac_expr ] "." ) ] +tacticals: [ +] + all_attrs: [ -| LIST0 ( "#[" LIST0 attr SEP "," "]" ) OPT legacy_attrs +| LIST0 ( "#[" LIST0 attr SEP "," "]" ) LIST0 legacy_attr ] attr: [ @@ -184,8 +178,12 @@ attr_value: [ | "(" LIST0 attr SEP "," ")" ] -legacy_attrs: [ -| OPT [ "Local" | "Global" ] OPT [ "Polymorphic" | "Monomorphic" ] OPT "Program" OPT [ "Cumulative" | "NonCumulative" ] OPT "Private" +legacy_attr: [ +| [ "Local" | "Global" ] +| [ "Polymorphic" | "Monomorphic" ] +| [ "Cumulative" | "NonCumulative" ] +| "Private" +| "Program" ] sort: [ @@ -278,13 +276,21 @@ binder: [ | name | "(" LIST1 name ":" type ")" | "(" name OPT ( ":" type ) ":=" term ")" +| implicit_binders +| generalizing_binder | "(" name ":" type "|" term ")" +| "'" pattern0 +] + +implicit_binders: [ | "{" LIST1 name OPT ( ":" type ) "}" | "[" LIST1 name OPT ( ":" type ) "]" +] + +generalizing_binder: [ | "`(" LIST1 typeclass_constraint SEP "," ")" | "`{" LIST1 typeclass_constraint SEP "," "}" | "`[" LIST1 typeclass_constraint SEP "," "]" -| "'" pattern0 ] typeclass_constraint: [ @@ -337,28 +343,10 @@ pattern0: [ | string ] -vernac: [ -| "Local" vernac_poly -| "Global" vernac_poly -| vernac_poly -] - -vernac_poly: [ -| "Polymorphic" vernac_aux -| "Monomorphic" vernac_aux -| vernac_aux -] - vernac_aux: [ -| "Program" gallina "." -| "Program" gallina_ext "." -| gallina "." -| gallina_ext "." | command "." | tactic_mode "." -| syntax "." | subprf -| query_command ] subprf: [ @@ -367,30 +355,6 @@ subprf: [ | "}" ] -gallina: [ -| thm_token ident_decl LIST0 binder ":" type LIST0 [ "with" ident_decl LIST0 binder ":" type ] -| assumption_token OPT ( "Inline" OPT ( "(" num ")" ) ) [ LIST1 ( "(" assumpt ")" ) | assumpt ] -| [ "Definition" | "Example" ] ident_decl def_body -| "Let" ident def_body -| "Inductive" inductive_definition LIST0 ( "with" inductive_definition ) -| "CoInductive" inductive_definition LIST0 ( "with" inductive_definition ) -| "Variant" inductive_definition LIST0 ( "with" inductive_definition ) -| [ "Record" | "Structure" ] inductive_definition LIST0 ( "with" inductive_definition ) -| "Class" inductive_definition LIST0 ( "with" inductive_definition ) -| "Fixpoint" fix_definition LIST0 ( "with" fix_definition ) -| "Let" "Fixpoint" fix_definition LIST0 ( "with" fix_definition ) -| "CoFixpoint" cofix_definition LIST0 ( "with" cofix_definition ) -| "Let" "CoFixpoint" cofix_definition LIST0 ( "with" cofix_definition ) -| "Scheme" scheme LIST0 ( "with" scheme ) -| "Combined" "Scheme" ident "from" LIST1 ident SEP "," -| "Register" qualid "as" qualid -| "Register" "Inline" qualid -| "Primitive" ident OPT [ ":" term ] ":=" register_token -| "Universe" LIST1 ident -| "Universes" LIST1 ident -| "Constraint" LIST1 univ_constraint SEP "," -] - fix_definition: [ | ident_decl LIST0 binder OPT fixannot OPT ( ":" type ) OPT [ ":=" term ] OPT decl_notations ] @@ -404,12 +368,8 @@ decl_notation: [ ] register_token: [ -| register_prim_token | "#int63_type" | "#float64_type" -] - -register_prim_token: [ | "#int63_head0" | "#int63_tail0" | "#int63_add" @@ -493,15 +453,6 @@ delta_flag: [ | OPT "-" "[" LIST1 smart_qualid "]" ] -smart_qualid: [ -| qualid -| by_notation -] - -by_notation: [ -| string OPT [ "%" ident ] -] - strategy_flag: [ | LIST1 red_flags | delta_flag @@ -523,13 +474,8 @@ ref_or_pattern_occ: [ ] occs_nums: [ -| LIST1 num_or_var -| "-" num_or_var LIST0 int_or_var -] - -num_or_var: [ -| num -| ident +| LIST1 [ num | ident ] +| "-" [ num | ident ] LIST0 int_or_var ] int_or_var: [ @@ -554,17 +500,12 @@ finite_token: [ | "Class" ] -inductive_definition: [ -| OPT ">" ident_decl LIST0 binder OPT [ "|" LIST0 binder ] OPT [ ":" type ] OPT ( ":=" OPT constructors_or_record ) OPT decl_notations +variant_definition: [ +| ident_decl LIST0 binder OPT [ "|" LIST0 binder ] OPT [ ":" type ] ":=" OPT "|" LIST1 constructor SEP "|" OPT decl_notations ] -constructors_or_record: [ -| OPT "|" LIST1 constructor SEP "|" -| OPT ident "{" LIST1 record_field SEP ";" "}" -] - -constructor: [ -| ident LIST0 binder OPT of_type +record_definition: [ +| OPT ">" ident_decl LIST0 binder OPT [ ":" type ] OPT ident "{" LIST0 record_field SEP ";" "}" OPT decl_notations ] record_field: [ @@ -577,13 +518,21 @@ field_body: [ | LIST0 binder ":=" term ] -cofix_definition: [ -| ident_decl LIST0 binder OPT ( ":" type ) OPT [ ":=" term ] OPT decl_notations +inductive_definition: [ +| OPT ">" ident_decl LIST0 binder OPT [ "|" LIST0 binder ] OPT [ ":" type ] OPT ( ":=" OPT constructors_or_record ) OPT decl_notations +] + +constructors_or_record: [ +| OPT "|" LIST1 constructor SEP "|" +| OPT ident "{" LIST0 record_field SEP ";" "}" +] + +constructor: [ +| ident LIST0 binder OPT of_type ] -scheme: [ -| scheme_kind -| ident ":=" scheme_kind +cofix_definition: [ +| ident_decl LIST0 binder OPT ( ":" type ) OPT [ ":=" term ] OPT decl_notations ] scheme_kind: [ @@ -601,60 +550,12 @@ sort_family: [ | "Type" ] -gallina_ext: [ -| "Module" OPT export_token ident LIST0 module_binder of_module_type OPT is_module_expr -| "Module" "Type" ident LIST0 module_binder LIST0 ( "<:" module_type_inl ) OPT is_module_type -| "Declare" "Module" OPT export_token ident LIST0 module_binder ":" module_type_inl -| "Section" ident -| "Chapter" ident -| "End" ident -| "Collection" ident ":=" section_subset_expr -| "Require" OPT export_token LIST1 qualid -| "From" qualid "Require" OPT export_token LIST1 qualid -| "Import" LIST1 qualid -| "Export" LIST1 qualid -| "Include" module_type_inl LIST0 ( "<+" module_expr_inl ) -| "Include" "Type" module_type_inl LIST0 ( "<+" module_type_inl ) -| "Transparent" LIST1 smart_qualid -| "Opaque" LIST1 smart_qualid -| "Strategy" LIST1 [ strategy_level "[" LIST1 smart_qualid "]" ] -| "Canonical" OPT "Structure" qualid OPT [ OPT univ_decl def_body ] -| "Canonical" OPT "Structure" by_notation -| "Coercion" qualid OPT univ_decl def_body -| "Identity" "Coercion" ident ":" class ">->" class -| "Coercion" qualid ":" class ">->" class -| "Coercion" by_notation ":" class ">->" class -| "Context" LIST1 binder -| "Instance" instance_name ":" term hint_info [ ":=" "{" [ LIST1 field_def SEP ";" | ] "}" | ":=" term | ] -| "Existing" "Instance" qualid hint_info -| "Existing" "Instances" LIST1 qualid OPT [ "|" num ] -| "Existing" "Class" qualid -| "Arguments" smart_qualid LIST0 argument_spec_block LIST0 [ "," LIST0 more_implicits_block ] OPT [ ":" LIST1 arguments_modifier SEP "," ] -| "Implicit" "Type" reserv_list -| "Implicit" "Types" reserv_list -| "Generalizable" [ "All" "Variables" | "No" "Variables" | [ "Variable" | "Variables" ] LIST1 ident ] -| "Export" "Set" LIST1 ident option_setting -| "Export" "Unset" LIST1 ident -] - -option_setting: [ -| -| int -| string -] - hint_info: [ | "|" OPT num OPT one_term -| -] - -export_token: [ -| "Import" -| "Export" ] module_binder: [ -| "(" OPT export_token LIST1 ident ":" module_type_inl ")" +| "(" OPT [ "Import" | "Export" ] LIST1 ident ":" module_type_inl ")" ] module_type_inl: [ @@ -662,6 +563,11 @@ module_type_inl: [ | module_type OPT functor_app_annot ] +functor_app_annot: [ +| "[" "inline" "at" "level" num "]" +| "[" "no" "inline" "]" +] + module_type: [ | qualid | "(" module_type ")" @@ -674,9 +580,9 @@ with_declaration: [ | "Module" qualid ":=" qualid ] -functor_app_annot: [ -| "[" "inline" "at" "level" num "]" -| "[" "no" "inline" "]" +module_expr_atom: [ +| qualid +| "(" LIST1 module_expr_atom ")" ] of_module_type: [ @@ -684,27 +590,18 @@ of_module_type: [ | LIST0 ( "<:" module_type_inl ) ] -is_module_type: [ -| ":=" module_type_inl LIST0 ( "<+" module_type_inl ) +module_expr_inl: [ +| "!" LIST1 module_expr_atom +| LIST1 module_expr_atom OPT functor_app_annot ] -module_expr_atom: [ +smart_qualid: [ | qualid -| "(" module_expr ")" -] - -module_expr: [ -| module_expr_atom -| module_expr module_expr_atom -] - -is_module_expr: [ -| ":=" module_expr_inl LIST0 ( "<+" module_expr_inl ) +| by_notation ] -module_expr_inl: [ -| "!" module_expr -| module_expr OPT functor_app_annot +by_notation: [ +| string OPT [ "%" ident ] ] argument_spec_block: [ @@ -747,31 +644,21 @@ strategy_level: [ | "transparent" ] -instance_name: [ -| ident_decl LIST0 binder -| -] - reserv_list: [ -| LIST1 reserv_tuple +| LIST1 ( "(" simple_reserv ")" ) | simple_reserv ] -reserv_tuple: [ -| "(" simple_reserv ")" -] - simple_reserv: [ -| LIST1 ident ":" term +| LIST1 ident ":" type ] command: [ | "Goal" term | "Declare" "Scope" ident | "Pwd" -| "Cd" -| "Cd" string -| "Load" [ "Verbose" | ] [ string | ident ] +| "Cd" OPT string +| "Load" OPT "Verbose" [ string | ident ] | "Declare" "ML" "Module" LIST1 string | "Locate" locatable | "Add" "LoadPath" string "as" dirpath @@ -821,101 +708,61 @@ command: [ | "Print" "Namespace" dirpath | "Inspect" num | "Add" "ML" "Path" string -| "Set" LIST1 ident option_setting -| "Unset" LIST1 ident +| OPT "Export" "Set" LIST1 ident OPT [ int | string ] +| OPT "Export" "Unset" LIST1 ident | "Print" "Table" LIST1 ident -| "Add" ident ident LIST1 option_ref_value -| "Add" ident LIST1 option_ref_value -| "Test" LIST1 ident "for" LIST1 option_ref_value -| "Test" LIST1 ident -| "Remove" ident ident LIST1 option_ref_value -| "Remove" ident LIST1 option_ref_value -| "Write" "State" ident -| "Write" "State" string -| "Restore" "State" ident -| "Restore" "State" string +| "Add" ident OPT ident LIST1 [ qualid | string ] +| "Test" LIST1 ident OPT ( "for" LIST1 [ qualid | string ] ) +| "Remove" OPT ident ident LIST1 [ qualid | string ] +| "Write" "State" [ ident | string ] +| "Restore" "State" [ ident | string ] | "Reset" "Initial" | "Reset" ident -| "Back" -| "Back" num -| "Debug" "On" -| "Debug" "Off" +| "Back" OPT num +| "Debug" [ "On" | "Off" ] | "Declare" "Reduction" ident ":=" red_expr | "Declare" "Custom" "Entry" ident | "Derive" ident "SuchThat" one_term "As" ident (* derive plugin *) | "Proof" | "Proof" "Mode" string | "Proof" term -| "Abort" -| "Abort" "All" -| "Abort" ident -| "Existential" num constr_body +| "Abort" OPT [ "All" | ident ] +| "Existential" num OPT ( ":" term ) ":=" term | "Admitted" | "Qed" | "Save" ident -| "Defined" -| "Defined" ident +| "Defined" OPT ident | "Restart" -| "Undo" -| "Undo" num -| "Undo" "To" num -| "Focus" -| "Focus" num +| "Undo" OPT ( OPT "To" num ) +| "Focus" OPT num | "Unfocus" | "Unfocused" -| "Show" -| "Show" num -| "Show" ident +| "Show" OPT [ ident | num ] | "Show" "Existentials" | "Show" "Universes" | "Show" "Conjectures" -| "Show" "Proof" +| "Show" "Proof" OPT ( "Diffs" OPT "removed" ) | "Show" "Intro" | "Show" "Intros" | "Show" "Match" qualid | "Guarded" -| "Create" "HintDb" ident [ "discriminated" | ] -| "Remove" "Hints" LIST1 qualid opt_hintbases -| "Hint" hint opt_hintbases +| "Create" "HintDb" ident OPT "discriminated" +| "Remove" "Hints" LIST1 qualid OPT ( ":" LIST1 ident ) +| "Hint" hint OPT ( ":" LIST1 ident ) | "Comments" LIST0 comment -| "Declare" "Instance" ident_decl LIST0 binder ":" term hint_info -| "Obligation" int "of" ident ":" term withtac -| "Obligation" int "of" ident withtac -| "Obligation" int ":" term withtac -| "Obligation" int withtac -| "Next" "Obligation" "of" ident withtac -| "Next" "Obligation" withtac -| "Solve" "Obligation" int "of" ident "with" ltac_expr -| "Solve" "Obligation" int "with" ltac_expr -| "Solve" "Obligations" "of" ident "with" ltac_expr -| "Solve" "Obligations" "with" ltac_expr -| "Solve" "Obligations" -| "Solve" "All" "Obligations" "with" ltac_expr -| "Solve" "All" "Obligations" -| "Admit" "Obligations" "of" ident -| "Admit" "Obligations" +| "Declare" "Instance" ident_decl LIST0 binder ":" term OPT hint_info +| "Obligation" int OPT ( "of" ident ) OPT ( ":" term OPT ( "with" ltac_expr ) ) +| "Next" "Obligation" OPT ( "of" ident ) OPT ( "with" ltac_expr ) +| "Solve" "Obligation" int OPT ( "of" ident ) "with" ltac_expr +| "Solve" "Obligations" OPT ( OPT ( "of" ident ) "with" ltac_expr ) +| "Solve" "All" "Obligations" OPT ( "with" ltac_expr ) +| "Admit" "Obligations" OPT ( "of" ident ) | "Obligation" "Tactic" ":=" ltac_expr | "Show" "Obligation" "Tactic" -| "Obligations" "of" ident -| "Obligations" -| "Preterm" "of" ident -| "Preterm" -| "Add" "Relation" one_term one_term "reflexivity" "proved" "by" one_term "symmetry" "proved" "by" one_term "as" ident -| "Add" "Relation" one_term one_term "reflexivity" "proved" "by" one_term "as" ident -| "Add" "Relation" one_term one_term "as" ident -| "Add" "Relation" one_term one_term "symmetry" "proved" "by" one_term "as" ident -| "Add" "Relation" one_term one_term "symmetry" "proved" "by" one_term "transitivity" "proved" "by" one_term "as" ident -| "Add" "Relation" one_term one_term "reflexivity" "proved" "by" one_term "transitivity" "proved" "by" one_term "as" ident -| "Add" "Relation" one_term one_term "reflexivity" "proved" "by" one_term "symmetry" "proved" "by" one_term "transitivity" "proved" "by" one_term "as" ident -| "Add" "Relation" one_term one_term "transitivity" "proved" "by" one_term "as" ident -| "Add" "Parametric" "Relation" LIST0 binder ":" one_term one_term "reflexivity" "proved" "by" one_term "symmetry" "proved" "by" one_term "as" ident -| "Add" "Parametric" "Relation" LIST0 binder ":" one_term one_term "reflexivity" "proved" "by" one_term "as" ident -| "Add" "Parametric" "Relation" LIST0 binder ":" one_term one_term "as" ident -| "Add" "Parametric" "Relation" LIST0 binder ":" one_term one_term "symmetry" "proved" "by" one_term "as" ident -| "Add" "Parametric" "Relation" LIST0 binder ":" one_term one_term "symmetry" "proved" "by" one_term "transitivity" "proved" "by" one_term "as" ident -| "Add" "Parametric" "Relation" LIST0 binder ":" one_term one_term "reflexivity" "proved" "by" one_term "transitivity" "proved" "by" one_term "as" ident -| "Add" "Parametric" "Relation" LIST0 binder ":" one_term one_term "reflexivity" "proved" "by" one_term "symmetry" "proved" "by" one_term "transitivity" "proved" "by" one_term "as" ident -| "Add" "Parametric" "Relation" LIST0 binder ":" one_term one_term "transitivity" "proved" "by" one_term "as" ident +| "Obligations" OPT ( "of" ident ) +| "Preterm" OPT ( "of" ident ) +| "Add" "Relation" one_term one_term OPT ( "reflexivity" "proved" "by" one_term ) OPT ( "symmetry" "proved" "by" one_term ) OPT ( "transitivity" "proved" "by" one_term ) "as" ident +| "Add" "Parametric" "Relation" LIST0 binder ":" one_term one_term OPT ( "reflexivity" "proved" "by" one_term ) OPT ( "symmetry" "proved" "by" one_term ) OPT ( "transitivity" "proved" "by" one_term ) "as" ident | "Add" "Setoid" one_term one_term one_term "as" ident | "Add" "Parametric" "Setoid" LIST0 binder ":" one_term one_term one_term "as" ident | "Add" "Morphism" one_term ":" ident @@ -929,9 +776,7 @@ command: [ | "Optimize" "Proof" | "Optimize" "Heap" | "Reset" "Ltac" "Profile" -| "Show" "Ltac" "Profile" -| "Show" "Ltac" "Profile" "CutOff" int -| "Show" "Ltac" "Profile" string +| "Show" "Ltac" "Profile" OPT [ "CutOff" int | string ] | "Show" "Lia" "Profile" (* micromega plugin *) | "Add" "InjTyp" one_term (* micromega plugin *) | "Add" "BinOp" one_term (* micromega plugin *) @@ -952,10 +797,10 @@ command: [ | "Show" "Zify" "BinRel" (* micromega plugin *) | "Show" "Zify" "Spec" (* micromega plugin *) | "Add" "Ring" ident ":" one_term OPT ( "(" LIST1 ring_mod SEP "," ")" ) (* setoid_ring plugin *) -| "Hint" "Cut" "[" hints_path "]" opthints +| "Hint" "Cut" "[" hints_path "]" OPT ( ":" LIST1 ident ) | "Typeclasses" "Transparent" LIST0 qualid | "Typeclasses" "Opaque" LIST0 qualid -| "Typeclasses" "eauto" ":=" debug eauto_search_strategy OPT int +| "Typeclasses" "eauto" ":=" OPT "debug" OPT [ "(bfs)" | "(dfs)" ] OPT int | "Proof" "with" ltac_expr OPT [ "using" section_subset_expr ] | "Proof" "using" section_subset_expr OPT [ "with" ltac_expr ] | "Tactic" "Notation" OPT ( "(" "at" "level" num ")" ) LIST1 ltac_production_item ":=" ltac_expr @@ -984,20 +829,15 @@ command: [ | "Extraction" "Blacklist" LIST1 ident (* extraction plugin *) | "Print" "Extraction" "Blacklist" (* extraction plugin *) | "Reset" "Extraction" "Blacklist" (* extraction plugin *) -| "Extract" "Constant" qualid LIST0 string "=>" mlname (* extraction plugin *) -| "Extract" "Inlined" "Constant" qualid "=>" mlname (* extraction plugin *) -| "Extract" "Inductive" qualid "=>" mlname "[" LIST0 mlname "]" OPT string (* extraction plugin *) +| "Extract" "Constant" qualid LIST0 string "=>" [ ident | string ] (* extraction plugin *) +| "Extract" "Inlined" "Constant" qualid "=>" [ ident | string ] (* extraction plugin *) +| "Extract" "Inductive" qualid "=>" [ ident | string ] "[" LIST0 [ ident | string ] "]" OPT string (* extraction plugin *) | "Show" "Extraction" (* extraction plugin *) | "Functional" "Case" fun_scheme_arg (* funind plugin *) | "Generate" "graph" "for" qualid (* funind plugin *) -| "Hint" "Rewrite" orient LIST1 one_term ":" LIST0 ident -| "Hint" "Rewrite" orient LIST1 one_term "using" ltac_expr ":" LIST0 ident -| "Hint" "Rewrite" orient LIST1 one_term -| "Hint" "Rewrite" orient LIST1 one_term "using" ltac_expr -| "Derive" "Inversion_clear" ident "with" one_term "Sort" sort_family -| "Derive" "Inversion_clear" ident "with" one_term -| "Derive" "Inversion" ident "with" one_term "Sort" sort_family -| "Derive" "Inversion" ident "with" one_term +| "Hint" "Rewrite" OPT [ "->" | "<-" ] LIST1 one_term OPT ( "using" ltac_expr ) OPT ( ":" LIST0 ident ) +| "Derive" "Inversion_clear" ident "with" one_term OPT ( "Sort" sort_family ) +| "Derive" "Inversion" ident "with" one_term OPT ( "Sort" sort_family ) | "Derive" "Dependent" "Inversion" ident "with" one_term "Sort" sort_family | "Derive" "Dependent" "Inversion_clear" ident "with" one_term "Sort" sort_family | "Declare" "Left" "Step" one_term @@ -1008,12 +848,84 @@ command: [ | "Numeral" "Notation" qualid qualid qualid ":" ident OPT numnotoption | "String" "Notation" qualid qualid qualid ":" ident | "SubClass" ident_decl def_body -] - -orient: [ -| "->" -| "<-" -| +| thm_token ident_decl LIST0 binder ":" type LIST0 [ "with" ident_decl LIST0 binder ":" type ] +| assumption_token OPT ( "Inline" OPT ( "(" num ")" ) ) [ LIST1 ( "(" assumpt ")" ) | assumpt ] +| [ "Definition" | "Example" ] ident_decl def_body +| "Let" ident def_body +| "Inductive" inductive_definition LIST0 ( "with" inductive_definition ) +| "Fixpoint" fix_definition LIST0 ( "with" fix_definition ) +| "Let" "Fixpoint" fix_definition LIST0 ( "with" fix_definition ) +| "CoFixpoint" cofix_definition LIST0 ( "with" cofix_definition ) +| "Let" "CoFixpoint" cofix_definition LIST0 ( "with" cofix_definition ) +| "Scheme" OPT ( ident ":=" ) scheme_kind LIST0 ( "with" OPT ( ident ":=" ) scheme_kind ) +| "Combined" "Scheme" ident "from" LIST1 ident SEP "," +| "Register" qualid "as" qualid +| "Register" "Inline" qualid +| "Primitive" ident OPT [ ":" term ] ":=" register_token +| "Universe" LIST1 ident +| "Universes" LIST1 ident +| "Constraint" LIST1 univ_constraint SEP "," +| "CoInductive" inductive_definition LIST0 ( "with" inductive_definition ) +| "Variant" variant_definition LIST0 ( "with" variant_definition ) +| [ "Record" | "Structure" ] record_definition LIST0 ( "with" record_definition ) +| "Class" inductive_definition LIST0 ( "with" inductive_definition ) +| "Module" OPT [ "Import" | "Export" ] ident LIST0 module_binder OPT of_module_type OPT ( ":=" LIST1 module_expr_inl SEP "<+" ) +| "Module" "Type" ident LIST0 module_binder LIST0 ( "<:" module_type_inl ) OPT ( ":=" LIST1 module_type_inl SEP "<+" ) +| "Declare" "Module" OPT [ "Import" | "Export" ] ident LIST0 module_binder ":" module_type_inl +| "Section" ident +| "Chapter" ident +| "End" ident +| "Collection" ident ":=" section_subset_expr +| "Require" OPT [ "Import" | "Export" ] LIST1 qualid +| "From" qualid "Require" OPT [ "Import" | "Export" ] LIST1 qualid +| "Import" LIST1 qualid +| "Export" LIST1 qualid +| "Include" module_type_inl LIST0 ( "<+" module_expr_inl ) +| "Include" "Type" LIST1 module_type_inl SEP "<+" +| "Transparent" LIST1 smart_qualid +| "Opaque" LIST1 smart_qualid +| "Strategy" LIST1 [ strategy_level "[" LIST1 smart_qualid "]" ] +| "Canonical" OPT "Structure" ident_decl def_body +| "Canonical" OPT "Structure" smart_qualid +| "Coercion" qualid OPT univ_decl def_body +| "Identity" "Coercion" ident ":" class ">->" class +| "Coercion" qualid ":" class ">->" class +| "Coercion" by_notation ":" class ">->" class +| "Context" LIST1 binder +| "Instance" OPT ( ident_decl LIST0 binder ) ":" term OPT hint_info OPT [ ":=" "{" LIST0 field_def "}" | ":=" term ] +| "Existing" "Instance" qualid OPT hint_info +| "Existing" "Instances" LIST1 qualid OPT [ "|" num ] +| "Existing" "Class" qualid +| "Arguments" smart_qualid LIST0 argument_spec_block LIST0 [ "," LIST0 more_implicits_block ] OPT [ ":" LIST1 arguments_modifier SEP "," ] +| "Implicit" [ "Type" | "Types" ] reserv_list +| "Generalizable" [ [ "Variable" | "Variables" ] LIST1 ident | "All" "Variables" | "No" "Variables" ] +| "Open" "Scope" ident +| "Close" "Scope" ident +| "Delimit" "Scope" ident "with" ident +| "Undelimit" "Scope" ident +| "Bind" "Scope" ident "with" LIST1 class +| "Infix" string ":=" one_term OPT [ "(" LIST1 syntax_modifier SEP "," ")" ] OPT [ ":" ident ] +| "Notation" ident LIST0 ident ":=" one_term OPT ( "(" "only" "parsing" ")" ) +| "Notation" string ":=" one_term OPT [ "(" LIST1 syntax_modifier SEP "," ")" ] OPT [ ":" ident ] +| "Format" "Notation" string string string +| "Reserved" "Infix" string OPT [ "(" LIST1 syntax_modifier SEP "," ")" ] +| "Reserved" "Notation" string OPT [ "(" LIST1 syntax_modifier SEP "," ")" ] +| "Eval" red_expr "in" term +| "Compute" term +| "Check" term +| "About" smart_qualid OPT ( "@{" LIST0 name "}" ) +| "SearchHead" one_term OPT ne_in_or_out_modules +| "SearchPattern" one_term OPT ne_in_or_out_modules +| "SearchRewrite" one_term OPT ne_in_or_out_modules +| "Search" searchabout_query OPT searchabout_queries +| "Time" command +| "Redirect" string command +| "Timeout" num command +| "Fail" command +| "Drop" +| "Quit" +| "BackTo" num +| "Show" "Goal" num "at" num ] section_subset_expr: [ @@ -1052,6 +964,10 @@ dirpath: [ | dirpath field_ident ] +bignat: [ +| numeral +] + locatable: [ | smart_qualid | "Term" smart_qualid @@ -1060,27 +976,17 @@ locatable: [ | "Module" qualid ] -option_ref_value: [ -| qualid -| string -] - comment: [ | one_term | string | num ] -reference_or_constr: [ -| qualid -| one_term -] - hint: [ -| "Resolve" LIST1 reference_or_constr hint_info +| "Resolve" LIST1 [ qualid | one_term ] OPT hint_info | "Resolve" "->" LIST1 qualid OPT num | "Resolve" "<-" LIST1 qualid OPT num -| "Immediate" LIST1 reference_or_constr +| "Immediate" LIST1 [ qualid | one_term ] | "Variables" "Transparent" | "Variables" "Opaque" | "Constants" "Transparent" @@ -1093,24 +999,9 @@ hint: [ | "Extern" num OPT one_term "=>" ltac_expr ] -constr_body: [ -| ":=" term -| ":" term ":=" term -] - -withtac: [ -| "with" ltac_expr -| -] - -ltac_def_kind: [ -| ":=" -| "::=" -] - tacdef_body: [ -| qualid LIST1 fun_var ltac_def_kind ltac_expr -| qualid ltac_def_kind ltac_expr +| qualid LIST1 fun_var [ ":=" | "::=" ] ltac_expr +| qualid [ ":=" | "::=" ] ltac_expr ] ltac_production_item: [ @@ -1120,13 +1011,8 @@ ltac_production_item: [ ] numnotoption: [ -| "(" "warning" "after" num ")" -| "(" "abstract" "after" num ")" -] - -mlname: [ -| ident (* extraction plugin *) -| string (* extraction plugin *) +| "(" "warning" "after" bignat ")" +| "(" "abstract" "after" bignat ")" ] int_or_id: [ @@ -1166,55 +1052,17 @@ field_mod: [ | "completeness" one_term (* setoid_ring plugin *) ] -debug: [ -| "debug" -| -] - -eauto_search_strategy: [ -| "(bfs)" -| "(dfs)" -| -] - -hints_path_atom: [ -| LIST1 qualid -| "_" -] - hints_path: [ | "(" hints_path ")" | hints_path "*" | "emp" | "eps" | hints_path "|" hints_path -| hints_path_atom +| LIST1 qualid +| "_" | hints_path hints_path ] -opthints: [ -| ":" LIST1 ident -| -] - -opt_hintbases: [ -| -| ":" LIST1 ident -] - -query_command: [ -| "Eval" red_expr "in" term "." -| "Compute" term "." -| "Check" term "." -| "About" smart_qualid OPT ( "@{" LIST0 name "}" ) "." -| "SearchHead" one_term in_or_out_modules "." -| "SearchPattern" one_term in_or_out_modules "." -| "SearchRewrite" one_term in_or_out_modules "." -| "Search" searchabout_query searchabout_queries "." -| "SearchAbout" searchabout_query searchabout_queries "." -| "SearchAbout" "[" LIST1 searchabout_query "]" in_or_out_modules "." -] - class: [ | "Funclass" | "Sortclass" @@ -1226,39 +1074,14 @@ ne_in_or_out_modules: [ | "outside" LIST1 qualid ] -in_or_out_modules: [ -| ne_in_or_out_modules -| -] - -positive_search_mark: [ -| "-" -| -] - searchabout_query: [ -| positive_search_mark string OPT ( "%" ident ) -| positive_search_mark one_term +| OPT "-" string OPT ( "%" ident ) +| OPT "-" one_term ] searchabout_queries: [ | ne_in_or_out_modules | searchabout_query searchabout_queries -| -] - -syntax: [ -| "Open" "Scope" ident -| "Close" "Scope" ident -| "Delimit" "Scope" ident "with" ident -| "Undelimit" "Scope" ident -| "Bind" "Scope" ident "with" LIST1 class -| "Infix" string ":=" one_term OPT [ "(" LIST1 syntax_modifier SEP "," ")" ] OPT [ ":" ident ] -| "Notation" ident LIST0 ident ":=" one_term OPT ( "(" "only" "parsing" ")" ) -| "Notation" string ":=" one_term OPT [ "(" LIST1 syntax_modifier SEP "," ")" ] OPT [ ":" ident ] -| "Format" "Notation" string string string -| "Reserved" "Infix" string OPT [ "(" LIST1 syntax_modifier SEP "," ")" ] -| "Reserved" "Notation" string OPT [ "(" LIST1 syntax_modifier SEP "," ")" ] ] level: [ @@ -1294,18 +1117,13 @@ syntax_extension_type: [ | "bigint" | "binder" | "constr" -| "constr" at_level_opt OPT constr_as_binder_kind +| "constr" OPT ( "at" level ) OPT constr_as_binder_kind | "pattern" | "pattern" "at" "level" num | "strict" "pattern" | "strict" "pattern" "at" "level" num | "closed" "binder" -| "custom" ident at_level_opt OPT constr_as_binder_kind -] - -at_level_opt: [ -| "at" level -| +| "custom" ident OPT ( "at" level ) OPT constr_as_binder_kind ] simple_tactic: [ @@ -1321,125 +1139,71 @@ simple_tactic: [ | "elimtype" one_term | "lapply" one_term | "transitivity" one_term -| "left" -| "eleft" -| "left" "with" bindings -| "eleft" "with" bindings -| "right" -| "eright" -| "right" "with" bindings -| "eright" "with" bindings -| "constructor" -| "constructor" int_or_var -| "constructor" int_or_var "with" bindings -| "econstructor" -| "econstructor" int_or_var -| "econstructor" int_or_var "with" bindings -| "specialize" constr_with_bindings -| "specialize" constr_with_bindings "as" simple_intropattern -| "symmetry" -| "symmetry" "in" in_clause -| "split" -| "esplit" -| "split" "with" bindings -| "esplit" "with" bindings -| "exists" -| "exists" LIST1 bindings SEP "," -| "eexists" -| "eexists" LIST1 bindings SEP "," -| "intros" "until" quantified_hypothesis -| "intro" -| "intro" ident -| "intro" ident "at" "top" -| "intro" ident "at" "bottom" -| "intro" ident "after" ident -| "intro" ident "before" ident -| "intro" "at" "top" -| "intro" "at" "bottom" -| "intro" "after" ident -| "intro" "before" ident -| "move" ident "at" "top" -| "move" ident "at" "bottom" -| "move" ident "after" ident -| "move" ident "before" ident -| "rename" LIST1 rename SEP "," +| "left" OPT ( "with" bindings ) +| "eleft" OPT ( "with" bindings ) +| "right" OPT ( "with" bindings ) +| "eright" OPT ( "with" bindings ) +| "constructor" OPT int_or_var OPT ( "with" bindings ) +| "econstructor" OPT ( int_or_var OPT ( "with" bindings ) ) +| "specialize" constr_with_bindings OPT ( "as" simple_intropattern ) +| "symmetry" OPT ( "in" in_clause ) +| "split" OPT ( "with" bindings ) +| "esplit" OPT ( "with" bindings ) +| "exists" OPT ( LIST1 bindings SEP "," ) +| "eexists" OPT ( LIST1 bindings SEP "," ) +| "intros" "until" [ ident | num ] +| "intro" OPT ident OPT where +| "move" ident OPT where +| "rename" LIST1 ( ident "into" ident ) SEP "," | "revert" LIST1 ident -| "simple" "induction" quantified_hypothesis -| "simple" "destruct" quantified_hypothesis -| "double" "induction" quantified_hypothesis quantified_hypothesis +| "simple" "induction" [ ident | num ] +| "simple" "destruct" [ ident | num ] +| "double" "induction" [ ident | num ] [ ident | num ] | "admit" -| "fix" ident num -| "cofix" ident | "clear" LIST0 ident | "clear" "-" LIST1 ident | "clearbody" LIST1 ident | "generalize" "dependent" one_term -| "replace" one_term "with" one_term clause_dft_concl by_arg_tac -| "replace" "->" one_term clause_dft_concl -| "replace" "<-" one_term clause_dft_concl -| "replace" one_term clause_dft_concl -| "simplify_eq" -| "simplify_eq" destruction_arg -| "esimplify_eq" -| "esimplify_eq" destruction_arg -| "discriminate" -| "discriminate" destruction_arg -| "ediscriminate" -| "ediscriminate" destruction_arg -| "injection" -| "injection" destruction_arg -| "einjection" -| "einjection" destruction_arg -| "injection" "as" LIST0 simple_intropattern -| "injection" destruction_arg "as" LIST0 simple_intropattern -| "einjection" "as" LIST0 simple_intropattern -| "einjection" destruction_arg "as" LIST0 simple_intropattern -| "simple" "injection" -| "simple" "injection" destruction_arg -| "dependent" "rewrite" orient one_term -| "dependent" "rewrite" orient one_term "in" ident -| "cutrewrite" orient one_term -| "cutrewrite" orient one_term "in" ident +| "replace" one_term "with" one_term OPT clause_dft_concl OPT ( "by" ltac_expr3 ) +| "replace" OPT [ "->" | "<-" ] one_term OPT clause_dft_concl +| "simplify_eq" OPT destruction_arg +| "esimplify_eq" OPT destruction_arg +| "discriminate" OPT destruction_arg +| "ediscriminate" OPT destruction_arg +| "injection" OPT destruction_arg OPT ( "as" LIST0 simple_intropattern ) +| "einjection" OPT destruction_arg OPT ( "as" LIST0 simple_intropattern ) +| "simple" "injection" OPT destruction_arg +| "dependent" "rewrite" OPT [ "->" | "<-" ] one_term OPT ( "in" ident ) +| "cutrewrite" OPT [ "->" | "<-" ] one_term OPT ( "in" ident ) | "decompose" "sum" one_term | "decompose" "record" one_term | "absurd" one_term | "contradiction" OPT constr_with_bindings -| "autorewrite" "with" LIST1 ident clause_dft_concl -| "autorewrite" "with" LIST1 ident clause_dft_concl "using" ltac_expr -| "autorewrite" "*" "with" LIST1 ident clause_dft_concl -| "autorewrite" "*" "with" LIST1 ident clause_dft_concl "using" ltac_expr -| "rewrite" "*" orient one_term "in" ident "at" occurrences by_arg_tac -| "rewrite" "*" orient one_term "at" occurrences "in" ident by_arg_tac -| "rewrite" "*" orient one_term "in" ident by_arg_tac -| "rewrite" "*" orient one_term "at" occurrences by_arg_tac -| "rewrite" "*" orient one_term by_arg_tac +| "autorewrite" OPT "*" "with" LIST1 ident OPT clause_dft_concl OPT ( "using" ltac_expr ) +| "rewrite" "*" OPT [ "->" | "<-" ] one_term OPT ( "in" ident ) OPT ( "at" occurrences OPT ( "by" ltac_expr3 ) ) +| "rewrite" "*" OPT [ "->" | "<-" ] one_term "at" occurrences "in" ident OPT ( "by" ltac_expr3 ) | "refine" one_term | "simple" "refine" one_term | "notypeclasses" "refine" one_term | "simple" "notypeclasses" "refine" one_term | "solve_constraints" -| "subst" LIST1 ident -| "subst" +| "subst" OPT ( LIST1 ident ) | "simple" "subst" | "evar" "(" ident ":" term ")" | "evar" one_term | "instantiate" "(" ident ":=" term ")" -| "instantiate" "(" int ":=" term ")" hloc +| "instantiate" "(" int ":=" term ")" OPT hloc | "instantiate" -| "stepl" one_term "by" ltac_expr -| "stepl" one_term -| "stepr" one_term "by" ltac_expr -| "stepr" one_term +| "stepl" one_term OPT ( "by" ltac_expr ) +| "stepr" one_term OPT ( "by" ltac_expr ) | "generalize_eqs" ident | "dependent" "generalize_eqs" ident | "generalize_eqs_vars" ident | "dependent" "generalize_eqs_vars" ident | "specialize_eqs" ident -| "hresolve_core" "(" ident ":=" one_term ")" "at" int_or_var "in" one_term -| "hresolve_core" "(" ident ":=" one_term ")" "in" one_term +| "hresolve_core" "(" ident ":=" one_term ")" OPT ( "at" int_or_var ) "in" one_term | "hget_evar" int_or_var -| "destauto" -| "destauto" "in" ident +| "destauto" OPT ( "in" ident ) | "transparent_abstract" ltac_expr3 | "transparent_abstract" ltac_expr3 "using" ident | "constr_eq" one_term one_term @@ -1471,27 +1235,24 @@ simple_tactic: [ | "show" "ltac" "profile" "cutoff" int | "show" "ltac" "profile" string | "restart_timer" OPT string -| "finish_timing" OPT string -| "finish_timing" "(" string ")" OPT string +| "finish_timing" OPT ( "(" string ")" ) OPT string | "eassumption" | "eexact" one_term -| "trivial" auto_using hintbases -| "info_trivial" auto_using hintbases -| "debug" "trivial" auto_using hintbases -| "auto" OPT int_or_var auto_using hintbases -| "info_auto" OPT int_or_var auto_using hintbases -| "debug" "auto" OPT int_or_var auto_using hintbases +| "trivial" OPT auto_using OPT hintbases +| "info_trivial" OPT auto_using OPT hintbases +| "debug" "trivial" OPT auto_using OPT hintbases +| "auto" OPT int_or_var OPT auto_using OPT hintbases +| "info_auto" OPT int_or_var OPT auto_using OPT hintbases +| "debug" "auto" OPT int_or_var OPT auto_using OPT hintbases | "prolog" "[" LIST0 one_term "]" int_or_var -| "eauto" OPT int_or_var OPT int_or_var auto_using hintbases -| "new" "auto" OPT int_or_var auto_using hintbases -| "debug" "eauto" OPT int_or_var OPT int_or_var auto_using hintbases -| "info_eauto" OPT int_or_var OPT int_or_var auto_using hintbases -| "dfs" "eauto" OPT int_or_var auto_using hintbases -| "autounfold" hintbases clause_dft_concl -| "autounfold_one" hintbases "in" ident -| "autounfold_one" hintbases -| "unify" one_term one_term -| "unify" one_term one_term "with" ident +| "eauto" OPT int_or_var OPT int_or_var OPT auto_using OPT hintbases +| "new" "auto" OPT int_or_var OPT auto_using OPT hintbases +| "debug" "eauto" OPT int_or_var OPT int_or_var OPT auto_using OPT hintbases +| "info_eauto" OPT int_or_var OPT int_or_var OPT auto_using OPT hintbases +| "dfs" "eauto" OPT int_or_var OPT auto_using OPT hintbases +| "autounfold" OPT hintbases OPT clause_dft_concl +| "autounfold_one" OPT hintbases OPT ( "in" ident ) +| "unify" one_term one_term OPT ( "with" ident ) | "convert_concl_no_check" one_term | "typeclasses" "eauto" "bfs" OPT int_or_var "with" LIST1 ident | "typeclasses" "eauto" OPT int_or_var "with" LIST1 ident @@ -1502,103 +1263,90 @@ simple_tactic: [ | "autoapply" one_term "using" ident | "autoapply" one_term "with" ident | "progress_evars" ltac_expr -| "rewrite_strat" rewstrategy -| "rewrite_db" ident "in" ident -| "rewrite_db" ident -| "substitute" orient constr_with_bindings -| "setoid_rewrite" orient constr_with_bindings -| "setoid_rewrite" orient constr_with_bindings "in" ident -| "setoid_rewrite" orient constr_with_bindings "at" occurrences -| "setoid_rewrite" orient constr_with_bindings "at" occurrences "in" ident -| "setoid_rewrite" orient constr_with_bindings "in" ident "at" occurrences -| "setoid_symmetry" -| "setoid_symmetry" "in" ident +| "rewrite_strat" rewstrategy OPT ( "in" ident ) +| "rewrite_db" ident OPT ( "in" ident ) +| "substitute" OPT [ "->" | "<-" ] constr_with_bindings +| "setoid_rewrite" OPT [ "->" | "<-" ] constr_with_bindings OPT ( "at" occurrences ) OPT ( "in" ident ) +| "setoid_rewrite" OPT [ "->" | "<-" ] constr_with_bindings "in" ident "at" occurrences +| "setoid_symmetry" OPT ( "in" ident ) | "setoid_reflexivity" | "setoid_transitivity" one_term | "setoid_etransitivity" | "decide" "equality" | "compare" one_term one_term -| "rewrite_strat" rewstrategy "in" ident -| "intros" intropattern_list_opt -| "eintros" intropattern_list_opt -| "apply" LIST1 constr_with_bindings_arg SEP "," in_hyp_as -| "eapply" LIST1 constr_with_bindings_arg SEP "," in_hyp_as -| "simple" "apply" LIST1 constr_with_bindings_arg SEP "," in_hyp_as -| "simple" "eapply" LIST1 constr_with_bindings_arg SEP "," in_hyp_as +| "intros" LIST0 intropattern +| "eintros" LIST0 intropattern +| "apply" LIST1 constr_with_bindings_arg SEP "," OPT in_hyp_as +| "eapply" LIST1 constr_with_bindings_arg SEP "," OPT in_hyp_as +| "simple" "apply" LIST1 constr_with_bindings_arg SEP "," OPT in_hyp_as +| "simple" "eapply" LIST1 constr_with_bindings_arg SEP "," OPT in_hyp_as | "elim" constr_with_bindings_arg OPT ( "using" constr_with_bindings ) | "eelim" constr_with_bindings_arg OPT ( "using" constr_with_bindings ) | "case" induction_clause_list | "ecase" induction_clause_list -| "fix" ident num "with" LIST1 fixdecl -| "cofix" ident "with" LIST1 cofixdecl +| "fix" ident num OPT ( "with" LIST1 fixdecl ) +| "cofix" ident OPT ( "with" LIST1 cofixdecl ) | "pose" bindings_with_parameters -| "pose" one_term as_name +| "pose" one_term OPT as_name | "epose" bindings_with_parameters -| "epose" one_term as_name -| "set" bindings_with_parameters clause_dft_concl -| "set" one_term as_name clause_dft_concl -| "eset" bindings_with_parameters clause_dft_concl -| "eset" one_term as_name clause_dft_concl -| "remember" one_term as_name eqn_ipat clause_dft_all -| "eremember" one_term as_name eqn_ipat clause_dft_all +| "epose" one_term OPT as_name +| "set" bindings_with_parameters OPT clause_dft_concl +| "set" one_term OPT as_name OPT clause_dft_concl +| "eset" bindings_with_parameters OPT clause_dft_concl +| "eset" one_term OPT as_name OPT clause_dft_concl +| "remember" one_term OPT as_name OPT eqn_ipat OPT clause_dft_all +| "eremember" one_term OPT as_name OPT eqn_ipat OPT clause_dft_all | "assert" "(" ident ":=" term ")" | "eassert" "(" ident ":=" term ")" -| "assert" "(" ident ":" term ")" by_tactic -| "eassert" "(" ident ":" term ")" by_tactic -| "enough" "(" ident ":" term ")" by_tactic -| "eenough" "(" ident ":" term ")" by_tactic -| "assert" one_term as_ipat by_tactic -| "eassert" one_term as_ipat by_tactic +| "assert" "(" ident ":" term ")" OPT ( "by" ltac_expr3 ) +| "eassert" "(" ident ":" term ")" OPT ( "by" ltac_expr3 ) +| "enough" "(" ident ":" term ")" OPT ( "by" ltac_expr3 ) +| "eenough" "(" ident ":" term ")" OPT ( "by" ltac_expr3 ) +| "assert" one_term OPT as_ipat OPT ( "by" ltac_expr3 ) +| "eassert" one_term OPT as_ipat OPT ( "by" ltac_expr3 ) | "pose" "proof" "(" ident ":=" term ")" | "epose" "proof" "(" ident ":=" term ")" -| "pose" "proof" term as_ipat -| "epose" "proof" term as_ipat -| "enough" one_term as_ipat by_tactic -| "eenough" one_term as_ipat by_tactic -| "generalize" one_term -| "generalize" one_term LIST1 one_term -| "generalize" one_term OPT ( "at" occs_nums ) as_name LIST0 [ "," pattern_occ as_name ] +| "pose" "proof" term OPT as_ipat +| "epose" "proof" term OPT as_ipat +| "enough" one_term OPT as_ipat OPT ( "by" ltac_expr3 ) +| "eenough" one_term OPT as_ipat OPT ( "by" ltac_expr3 ) +| "generalize" one_term OPT ( LIST1 one_term ) +| "generalize" one_term OPT ( "at" occs_nums ) OPT as_name LIST0 [ "," pattern_occ OPT as_name ] | "induction" induction_clause_list | "einduction" induction_clause_list | "destruct" induction_clause_list | "edestruct" induction_clause_list -| "rewrite" LIST1 oriented_rewriter SEP "," clause_dft_concl by_tactic -| "erewrite" LIST1 oriented_rewriter SEP "," clause_dft_concl by_tactic -| "dependent" [ "simple" "inversion" | "inversion" | "inversion_clear" ] quantified_hypothesis as_or_and_ipat OPT [ "with" one_term ] -| "simple" "inversion" quantified_hypothesis as_or_and_ipat in_hyp_list -| "inversion" quantified_hypothesis as_or_and_ipat in_hyp_list -| "inversion_clear" quantified_hypothesis as_or_and_ipat in_hyp_list -| "inversion" quantified_hypothesis "using" one_term in_hyp_list -| "red" clause_dft_concl -| "hnf" clause_dft_concl -| "simpl" OPT delta_flag OPT ref_or_pattern_occ clause_dft_concl -| "cbv" OPT strategy_flag clause_dft_concl -| "cbn" OPT strategy_flag clause_dft_concl -| "lazy" OPT strategy_flag clause_dft_concl -| "compute" OPT delta_flag clause_dft_concl -| "vm_compute" OPT ref_or_pattern_occ clause_dft_concl -| "native_compute" OPT ref_or_pattern_occ clause_dft_concl -| "unfold" LIST1 unfold_occ SEP "," clause_dft_concl -| "fold" LIST1 one_term clause_dft_concl -| "pattern" LIST1 pattern_occ SEP "," clause_dft_concl -| "change" conversion clause_dft_concl -| "change_no_check" conversion clause_dft_concl +| "rewrite" LIST1 oriented_rewriter SEP "," OPT clause_dft_concl OPT ( "by" ltac_expr3 ) +| "erewrite" LIST1 oriented_rewriter SEP "," OPT clause_dft_concl OPT ( "by" ltac_expr3 ) +| "dependent" [ "simple" "inversion" | "inversion" | "inversion_clear" ] [ ident | num ] OPT as_or_and_ipat OPT [ "with" one_term ] +| "simple" "inversion" [ ident | num ] OPT as_or_and_ipat OPT ( "in" LIST1 ident ) +| "inversion" [ ident | num ] OPT as_or_and_ipat OPT ( "in" LIST1 ident ) +| "inversion_clear" [ ident | num ] OPT as_or_and_ipat OPT ( "in" LIST1 ident ) +| "inversion" [ ident | num ] "using" one_term OPT ( "in" LIST1 ident ) +| "red" OPT clause_dft_concl +| "hnf" OPT clause_dft_concl +| "simpl" OPT delta_flag OPT ref_or_pattern_occ OPT clause_dft_concl +| "cbv" OPT strategy_flag OPT clause_dft_concl +| "cbn" OPT strategy_flag OPT clause_dft_concl +| "lazy" OPT strategy_flag OPT clause_dft_concl +| "compute" OPT delta_flag OPT clause_dft_concl +| "vm_compute" OPT ref_or_pattern_occ OPT clause_dft_concl +| "native_compute" OPT ref_or_pattern_occ OPT clause_dft_concl +| "unfold" LIST1 unfold_occ SEP "," OPT clause_dft_concl +| "fold" LIST1 one_term OPT clause_dft_concl +| "pattern" LIST1 pattern_occ SEP "," OPT clause_dft_concl +| "change" conversion OPT clause_dft_concl +| "change_no_check" conversion OPT clause_dft_concl | "btauto" | "rtauto" -| "congruence" -| "congruence" int -| "congruence" "with" LIST1 one_term -| "congruence" int "with" LIST1 one_term +| "congruence" OPT int OPT ( "with" LIST1 one_term ) | "f_equal" -| "firstorder" OPT ltac_expr firstorder_using -| "firstorder" OPT ltac_expr "with" LIST1 ident -| "firstorder" OPT ltac_expr firstorder_using "with" LIST1 ident +| "firstorder" OPT ltac_expr firstorder_rhs | "gintuition" OPT ltac_expr -| "functional" "inversion" quantified_hypothesis OPT qualid (* funind plugin *) -| "functional" "induction" LIST1 one_term fun_ind_using with_names (* funind plugin *) -| "soft" "functional" "induction" LIST1 one_term fun_ind_using with_names (* funind plugin *) -| "psatz_Z" int_or_var ltac_expr (* micromega plugin *) -| "psatz_Z" ltac_expr (* micromega plugin *) +| "functional" "inversion" [ ident | num ] OPT qualid (* funind plugin *) +| "functional" "induction" LIST1 one_term OPT fun_ind_using OPT with_names (* funind plugin *) +| "soft" "functional" "induction" LIST1 one_term OPT fun_ind_using OPT with_names (* funind plugin *) +| "psatz_Z" OPT int_or_var ltac_expr | "xlia" ltac_expr (* micromega plugin *) | "xnlia" ltac_expr (* micromega plugin *) | "xnra" ltac_expr (* micromega plugin *) @@ -1608,10 +1356,8 @@ simple_tactic: [ | "sos_R" ltac_expr (* micromega plugin *) | "lra_Q" ltac_expr (* micromega plugin *) | "lra_R" ltac_expr (* micromega plugin *) -| "psatz_R" int_or_var ltac_expr (* micromega plugin *) -| "psatz_R" ltac_expr (* micromega plugin *) -| "psatz_Q" int_or_var ltac_expr (* micromega plugin *) -| "psatz_Q" ltac_expr (* micromega plugin *) +| "psatz_R" OPT int_or_var ltac_expr +| "psatz_Q" OPT int_or_var ltac_expr | "zify_iter_specs" (* micromega plugin *) | "zify_op" (* micromega plugin *) | "zify_saturate" (* micromega plugin *) @@ -1619,14 +1365,37 @@ simple_tactic: [ | "zify_elim_let" (* micromega plugin *) | "nsatz_compute" one_term (* nsatz plugin *) | "omega" (* omega plugin *) -| "protect_fv" string "in" ident (* setoid_ring plugin *) -| "protect_fv" string (* setoid_ring plugin *) +| "protect_fv" string OPT ( "in" ident ) | "ring_lookup" ltac_expr0 "[" LIST0 one_term "]" LIST1 one_term (* setoid_ring plugin *) | "field_lookup" ltac_expr "[" LIST0 one_term "]" LIST1 one_term (* setoid_ring plugin *) +| "classical_left" +| "classical_right" +| "contradict" ident +| "discrR" +| "easy" +| "exfalso" +| "inversion_sigma" +| "lia" +| "lra" +| "nia" +| "nra" +| "split_Rabs" +| "split_Rmult" +| "tauto" +| "zify" +| "assert_fails" ltac_expr3 +| "assert_succeeds" ltac_expr3 +| "field" OPT ( "[" LIST1 term "]" ) +| "field_simplify" OPT ( "[" LIST1 term "]" ) LIST1 term OPT ( "in" ident ) +| "field_simplify_eq" OPT ( "[" LIST1 term "]" ) OPT ( "in" ident ) +| "intuition" OPT ltac_expr +| "nsatz" OPT ( "with" "radicalmax" ":=" term "strategy" ":=" term "parameters" ":=" term "variables" ":=" term ) +| "psatz" term OPT int_or_var +| "ring" OPT ( "[" LIST1 term "]" ) +| "ring_simplify" OPT ( "[" LIST1 term "]" ) LIST1 term OPT ( "in" ident ) ] hloc: [ -| | "in" "|-" "*" | "in" ident | "in" "(" "Type" "of" ident ")" @@ -1635,15 +1404,6 @@ hloc: [ | "in" "(" "value" "of" ident ")" ] -rename: [ -| ident "into" ident -] - -by_arg_tac: [ -| "by" ltac_expr3 -| -] - in_clause: [ | LIST0 hypident_occ SEP "," OPT ( "|-" OPT concl_occ ) | "*" "|-" OPT concl_occ @@ -1666,7 +1426,6 @@ hypident: [ as_ipat: [ | "as" simple_intropattern -| ] or_and_intropattern_loc: [ @@ -1676,29 +1435,19 @@ or_and_intropattern_loc: [ as_or_and_ipat: [ | "as" or_and_intropattern_loc -| ] eqn_ipat: [ | "eqn" ":" naming_intropattern -| "_eqn" ":" naming_intropattern -| "_eqn" -| ] as_name: [ | "as" ident -| -] - -by_tactic: [ -| "by" ltac_expr3 -| ] rewriter: [ | "!" constr_with_bindings_arg -| [ "?" | "?" ] constr_with_bindings_arg +| "?" constr_with_bindings_arg | num "!" constr_with_bindings_arg | num [ "?" | "?" ] constr_with_bindings_arg | num constr_with_bindings_arg @@ -1706,24 +1455,19 @@ rewriter: [ ] oriented_rewriter: [ -| orient rewriter +| OPT [ "->" | "<-" ] rewriter ] induction_clause: [ -| destruction_arg as_or_and_ipat eqn_ipat opt_clause +| destruction_arg OPT as_or_and_ipat OPT eqn_ipat OPT opt_clause ] induction_clause_list: [ -| LIST1 induction_clause SEP "," OPT ( "using" constr_with_bindings ) opt_clause +| LIST1 induction_clause SEP "," OPT ( "using" constr_with_bindings ) OPT opt_clause ] auto_using: [ | "using" LIST1 one_term SEP "," -| -] - -intropattern_list_opt: [ -| LIST0 intropattern ] or_and_intropattern: [ @@ -1733,14 +1477,13 @@ or_and_intropattern: [ ] intropattern_or_list_or: [ -| intropattern_or_list_or "|" intropattern_list_opt -| intropattern_list_opt +| LIST0 intropattern LIST0 ( "|" LIST0 intropattern ) ] equality_intropattern: [ | "->" | "<-" -| "[=" intropattern_list_opt "]" +| "[=" LIST0 intropattern "]" ] naming_intropattern: [ @@ -1787,7 +1530,6 @@ comparison: [ hintbases: [ | "with" "*" | "with" LIST1 ident -| ] bindings_with_parameters: [ @@ -1797,28 +1539,19 @@ bindings_with_parameters: [ clause_dft_concl: [ | "in" in_clause | OPT ( "at" occs_nums ) -| ] clause_dft_all: [ | "in" in_clause -| ] opt_clause: [ | "in" in_clause | "at" occs_nums -| -] - -in_hyp_list: [ -| "in" LIST1 ident -| ] in_hyp_as: [ -| "in" ident as_ipat -| +| "in" ident OPT as_ipat ] simple_binder: [ @@ -1827,12 +1560,11 @@ simple_binder: [ ] fixdecl: [ -| "(" ident LIST0 simple_binder struct_annot ":" term ")" +| "(" ident LIST0 simple_binder OPT struct_annot ":" term ")" ] struct_annot: [ | "{" "struct" name "}" -| ] cofixdecl: [ @@ -1840,12 +1572,7 @@ cofixdecl: [ ] constr_with_bindings: [ -| one_term with_bindings -] - -with_bindings: [ -| "with" bindings -| +| one_term OPT ( "with" bindings ) ] destruction_arg: [ @@ -1859,11 +1586,6 @@ constr_with_bindings_arg: [ | constr_with_bindings ] -quantified_hypothesis: [ -| ident -| num -] - conversion: [ | one_term | one_term "with" one_term @@ -1874,17 +1596,14 @@ firstorder_using: [ | "using" qualid | "using" qualid "," LIST1 qualid SEP "," | "using" qualid qualid LIST0 qualid -| ] fun_ind_using: [ | "using" constr_with_bindings (* funind plugin *) -| (* funind plugin *) ] with_names: [ | "as" simple_intropattern (* funind plugin *) -| (* funind plugin *) ] occurrences: [ @@ -2032,16 +1751,11 @@ tactic_arg: [ | "eval" red_expr "in" term | "context" ident "[" term "]" | "type" "of" term -| "fresh" LIST0 fresh_id +| "fresh" LIST0 [ string | qualid ] | "type_term" one_term | "numgoals" ] -fresh_id: [ -| string -| qualid -] - tactic_arg_compat: [ | tactic_arg | term diff --git a/doc/tools/docgram/prodn.edit_mlg b/doc/tools/docgram/prodn.edit_mlg deleted file mode 100644 index 8bd8cad6b5..0000000000 --- a/doc/tools/docgram/prodn.edit_mlg +++ /dev/null @@ -1,24 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* <O___,, * (see version control and CREDITS file for authors & dates) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -(* Defines additional productions and edits for use in documentation. Not compiled into Coq *) -(* Contents used to generate prodn in doc *) - -DOC_GRAMMAR - -(* todo: doesn't work, gives -ltac_match: @match_key @ltac_expr with {? %| } {+| @ltac_expr } end -instead of -ltac_match: @match_key @ltac_expr with {? %| } {+| {| @match_pattern | _ } => @ltac_expr } end - -SPLICE: [ -| match_rule -] -*) diff --git a/doc/tools/docgram/productionlist.edit_mlg b/doc/tools/docgram/productionlist.edit_mlg deleted file mode 100644 index 641ab8fbe5..0000000000 --- a/doc/tools/docgram/productionlist.edit_mlg +++ /dev/null @@ -1,14 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* <O___,, * (see version control and CREDITS file for authors & dates) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -(* Defines additional productions and edits for use in documentation. Not compiled into Coq *) -(* Contents used to generate productionlists in doc *) - -DOC_GRAMMAR diff --git a/gramlib/grammar.ml b/gramlib/grammar.ml index 0024d70466..d6951fff6d 100644 --- a/gramlib/grammar.ml +++ b/gramlib/grammar.ml @@ -8,8 +8,6 @@ open Util (* Functorial interface *) -module type GLexerType = Plexing.Lexer - type norec type mayrec @@ -20,6 +18,7 @@ module type S = sig module Parsable : sig type t val make : ?loc:Loc.t -> char Stream.t -> t + val comments : t -> ((int * int) * string) list end val tokens : string -> (string option * int) list @@ -27,6 +26,7 @@ module type S = sig module Entry : sig type 'a t val make : string -> 'a t + val create : string -> 'a t val parse : 'a t -> Parsable.t -> 'a val name : 'a t -> string val of_parser : string -> (Plexing.location_function -> te Stream.t -> 'a) -> 'a t @@ -51,7 +51,7 @@ module type S = sig val self : ('self, mayrec, 'self) t val next : ('self, mayrec, 'self) t val token : 'c pattern -> ('self, norec, 'c) t - val rules : warning:(string -> unit) option -> 'a Rules.t list -> ('self, norec, 'a) t + val rules : 'a Rules.t list -> ('self, norec, 'a) t end and Rule : sig @@ -77,21 +77,39 @@ module type S = sig val make : ('a, _, 'f, Loc.t -> 'a) Rule.t -> 'f -> 'a t end - module Unsafe : - sig + type 'a single_extend_statement = + string option * Gramext.g_assoc option * 'a Production.t list + + type 'a extend_statement = + { pos : Gramext.position option + ; data : 'a single_extend_statement list + } + + val generalize_symbol : ('a, 'tr, 'c) Symbol.t -> ('a, norec, 'c) Symbol.t option + + val mk_rule : 'a pattern list -> string Rules.t + + (* Used in custom entries, should tweak? *) + val level_of_nonterm : ('a, norec, 'c) Symbol.t -> string option + +end + +module type ExtS = sig + + include S + + val safe_extend : 'a Entry.t -> 'a extend_statement -> unit + val safe_delete_rule : 'a Entry.t -> 'a Production.t -> unit + + module Unsafe : sig val clear_entry : 'a Entry.t -> unit end - val safe_extend : warning:(string -> unit) option -> - 'a Entry.t -> Gramext.position option -> - (string option * Gramext.g_assoc option * 'a Production.t list) - list -> - unit - val safe_delete_rule : 'a Entry.t -> ('a, _, 'f, 'r) Rule.t -> unit + end (* Implementation *) -module GMake (L : GLexerType) = struct +module GMake (L : Plexing.S) = struct type te = L.te type 'c pattern = 'c L.pattern @@ -324,7 +342,7 @@ let and_and_tree (type s tr' trt tr trn trs trb f) (ar : (tr', trt, tr) ty_and_r | MayRec2, _, MayRec -> MayRec2 | MayRec2, _, NoRec -> MayRec2 | NoRec2, NoRec3, NoRec -> NoRec2 -let insert_tree (type s trs trt tr p k a) ~warning entry_name (ar : (trs, trt, tr) ty_and_ex) (gsymbols : (s, trs, p) ty_symbols) (pf : (p, k, a) rel_prod) (action : k) (tree : (s, trt, a) ty_tree) : (s, tr, a) ty_tree = +let insert_tree (type s trs trt tr p k a) entry_name (ar : (trs, trt, tr) ty_and_ex) (gsymbols : (s, trs, p) ty_symbols) (pf : (p, k, a) rel_prod) (action : k) (tree : (s, trt, a) ty_tree) : (s, tr, a) ty_tree = let rec insert : type trs trt tr p f k. (trs, trt, tr) ty_and_ex -> (s, trs, p) ty_symbols -> (p, k, f) rel_prod -> (s, trt, f) ty_tree -> k -> (s, tr, f) ty_tree = fun ar symbols pf tree action -> match symbols, pf with @@ -338,15 +356,15 @@ let insert_tree (type s trs trt tr p k a) ~warning entry_name (ar : (trs, trt, t | NR10, Node (_, n) -> Node (MayRec3, node n) | NR11, Node (NoRec3, n) -> Node (NoRec3, node n) | NR11, LocAct (old_action, action_list) -> - begin match warning with - | None -> () - | Some warn_fn -> + (* What to do about this warning? For now it is disabled *) + if false then + begin let msg = "<W> Grammar extension: " ^ (if entry_name = "" then "" else "in ["^entry_name^"%s], ") ^ "some rule has been masked" in - warn_fn msg - end; + Feedback.msg_warning (Pp.str msg) + end; LocAct (action, old_action :: action_list) | NR11, DeadEnd -> LocAct (action, []) and insert_in_tree : type trs trs' trs'' trt tr a p f k. (trs'', trt, tr) ty_and_ex -> (trs, trs', trs'') ty_and_rec -> (s, trs, a) ty_symbol -> (s, trs', p) ty_symbols -> (p, k, a -> f) rel_prod -> (s, trt, f) ty_tree -> k -> (s, tr, f) ty_tree = @@ -405,14 +423,14 @@ let insert_tree (type s trs trt tr p k a) ~warning entry_name (ar : (trs, trt, t in insert ar gsymbols pf tree action -let insert_tree_norec (type s p k a) ~warning entry_name (gsymbols : (s, norec, p) ty_symbols) (pf : (p, k, a) rel_prod) (action : k) (tree : (s, norec, a) ty_tree) : (s, norec, a) ty_tree = - insert_tree ~warning entry_name NR11 gsymbols pf action tree +let insert_tree_norec (type s p k a) entry_name (gsymbols : (s, norec, p) ty_symbols) (pf : (p, k, a) rel_prod) (action : k) (tree : (s, norec, a) ty_tree) : (s, norec, a) ty_tree = + insert_tree entry_name NR11 gsymbols pf action tree -let insert_tree (type s trs trt p k a) ~warning entry_name (gsymbols : (s, trs, p) ty_symbols) (pf : (p, k, a) rel_prod) (action : k) (tree : (s, trt, a) ty_tree) : (s, a) ty_mayrec_tree = +let insert_tree (type s trs trt p k a) entry_name (gsymbols : (s, trs, p) ty_symbols) (pf : (p, k, a) rel_prod) (action : k) (tree : (s, trt, a) ty_tree) : (s, a) ty_mayrec_tree = let MayRecNR ar = and_symbols_tree gsymbols tree in - MayRecTree (insert_tree ~warning entry_name ar gsymbols pf action tree) + MayRecTree (insert_tree entry_name ar gsymbols pf action tree) -let srules (type self a) ~warning (rl : a ty_rules list) : (self, norec, a) ty_symbol = +let srules (type self a) (rl : a ty_rules list) : (self, norec, a) ty_symbol = let rec retype_tree : type s a. (s, norec, a) ty_tree -> (self, norec, a) ty_tree = function | Node (NoRec3, {node = s; son = son; brother = bro}) -> @@ -439,7 +457,7 @@ let srules (type self a) ~warning (rl : a ty_rules list) : (self, norec, a) ty_s (fun tree (TRules (symbols, action)) -> let symbols = retype_rule symbols in let AnyS (symbols, pf) = get_symbols symbols in - insert_tree_norec ~warning "" symbols pf action tree) + insert_tree_norec "" symbols pf action tree) DeadEnd rl in Stree t @@ -449,19 +467,19 @@ let is_level_labelled n (Level lev) = Some n1 -> n = n1 | None -> false -let insert_level (type s tr p k) ~warning entry_name (symbols : (s, tr, p) ty_symbols) (pf : (p, k, Loc.t -> s) rel_prod) (action : k) (slev : s ty_level) : s ty_level = +let insert_level (type s tr p k) entry_name (symbols : (s, tr, p) ty_symbols) (pf : (p, k, Loc.t -> s) rel_prod) (action : k) (slev : s ty_level) : s ty_level = match symbols with | TCns (_, Sself, symbols) -> let Level slev = slev in let RelS pf = pf in - let MayRecTree lsuffix = insert_tree ~warning entry_name symbols pf action slev.lsuffix in + let MayRecTree lsuffix = insert_tree entry_name symbols pf action slev.lsuffix in Level {assoc = slev.assoc; lname = slev.lname; lsuffix = lsuffix; lprefix = slev.lprefix} | _ -> let Level slev = slev in - let MayRecTree lprefix = insert_tree ~warning entry_name symbols pf action slev.lprefix in + let MayRecTree lprefix = insert_tree entry_name symbols pf action slev.lprefix in Level {assoc = slev.assoc; lname = slev.lname; lsuffix = slev.lsuffix; lprefix = lprefix} @@ -475,34 +493,27 @@ let empty_lev lname assoc = Level {assoc = assoc; lname = lname; lsuffix = DeadEnd; lprefix = DeadEnd} -let change_lev ~warning (Level lev) n lname assoc = +let change_lev (Level lev) n lname assoc = let a = match assoc with None -> lev.assoc | Some a -> if a <> lev.assoc then - begin - match warning with - | None -> () - | Some warn_fn -> - warn_fn ("<W> Changing associativity of level \""^n^"\"") - end; - a + Feedback.msg_warning (Pp.str ("<W> Changing associativity of level \""^n^"\"")); + a in - begin match lname with - Some n -> - if lname <> lev.lname then - begin match warning with - | None -> () - | Some warn_fn -> - warn_fn ("<W> Level label \""^n^"\" ignored") - end; - | None -> () + begin + match lname with + | Some n -> + (* warning disabled; it was in the past *) + if false && lname <> lev.lname then + Feedback.msg_warning (Pp.str ("<W> Level label \""^n^"\" ignored")) + | None -> () end; Level {assoc = a; lname = lev.lname; lsuffix = lev.lsuffix; lprefix = lev.lprefix} -let get_level ~warning entry position levs = +let get_level entry position levs = match position with Some First -> [], empty_lev, levs | Some Last -> levs, empty_lev, [] @@ -515,7 +526,7 @@ let get_level ~warning entry position levs = flush stderr; failwith "Grammar.extend" | lev :: levs -> - if is_level_labelled n lev then [], change_lev ~warning lev n, levs + if is_level_labelled n lev then [], change_lev lev n, levs else let (levs1, rlev, levs2) = get levs in lev :: levs1, rlev, levs2 in @@ -550,7 +561,7 @@ let get_level ~warning entry position levs = get levs | None -> match levs with - lev :: levs -> [], change_lev ~warning lev "<top>", levs + lev :: levs -> [], change_lev lev "<top>", levs | [] -> [], empty_lev, [] let change_to_self0 (type s) (type trec) (type a) (entry : s ty_entry) : (s, trec, a) ty_symbol -> (s, a) ty_mayrec_symbol = @@ -600,7 +611,7 @@ let insert_tokens gram symbols = in linsert symbols -let levels_of_rules ~warning entry position rules = +let levels_of_rules entry position rules = let elev = match entry.edesc with Dlevels elev -> elev @@ -612,7 +623,7 @@ let levels_of_rules ~warning entry position rules = match rules with | [] -> elev | _ -> - let (levs1, make_lev, levs2) = get_level ~warning entry position elev in + let (levs1, make_lev, levs2) = get_level entry position elev in let (levs, _) = List.fold_left (fun (levs, make_lev) (lname, assoc, level) -> @@ -623,7 +634,7 @@ let levels_of_rules ~warning entry position rules = let MayRecRule symbols = change_to_self entry symbols in let AnyS (symbols, pf) = get_symbols symbols in insert_tokens egram symbols; - insert_level ~warning entry.ename symbols pf action lev) + insert_level entry.ename symbols pf action lev) lev level in lev :: levs, empty_lev) @@ -1479,8 +1490,8 @@ let init_entry_functions entry = let f = continue_parser_of_entry entry in entry.econtinue <- f; f lev bp a strm) -let extend_entry ~warning entry position rules = - let elev = levels_of_rules ~warning entry position rules in +let extend_entry entry position rules = + let elev = levels_of_rules entry position rules in entry.edesc <- Dlevels elev; init_entry_functions entry (* Deleting a rule *) @@ -1508,7 +1519,7 @@ module Parsable = struct { pa_chr_strm : char Stream.t ; pa_tok_strm : L.te Stream.t ; pa_loc_func : Plexing.location_function - } + ; lexer_state : L.State.t ref } let parse_parsable entry p = let efun = entry.estart 0 in @@ -1544,9 +1555,26 @@ module Parsable = struct let loc = Stream.count cs, Stream.count cs + 1 in restore (); Ploc.raise (Ploc.make_unlined loc) exc + let parse_parsable e p = + L.State.set !(p.lexer_state); + try + let c = parse_parsable e p in + p.lexer_state := L.State.get (); + c + with Ploc.Exc (loc,e) -> + L.State.drop (); + let loc' = Loc.get_loc (Exninfo.info e) in + let loc = match loc' with None -> loc | Some loc -> loc in + Loc.raise ~loc e + let make ?loc cs = + let lexer_state = ref (L.State.init ()) in + L.State.set !lexer_state; let (ts, lf) = L.tok_func ?loc cs in - {pa_chr_strm = cs; pa_tok_strm = ts; pa_loc_func = lf} + lexer_state := L.State.get (); + {pa_chr_strm = cs; pa_tok_strm = ts; pa_loc_func = lf; lexer_state} + + let comments p = L.State.get_comments !(p.lexer_state) end @@ -1557,6 +1585,7 @@ module Entry = struct econtinue = (fun _ _ _ (strm__ : _ Stream.t) -> raise Stream.Failure); edesc = Dlevels []} + let create = make let parse (e : 'a t) p : 'a = Parsable.parse_parsable e p let parse_token_stream (e : 'a t) ts : 'a = @@ -1589,7 +1618,7 @@ module rec Symbol : sig val self : ('self, mayrec, 'self) t val next : ('self, mayrec, 'self) t val token : 'c pattern -> ('self, norec, 'c) t - val rules : warning:(string -> unit) option -> 'a Rules.t list -> ('self, norec, 'a) t + val rules : 'a Rules.t list -> ('self, norec, 'a) t end = struct @@ -1604,7 +1633,7 @@ end = struct let self = Sself let next = Snext let token tok = Stoken tok - let rules ~warning (t : 'a Rules.t list) = srules ~warning t + let rules (t : 'a Rules.t list) = srules t end and Rule : sig @@ -1656,14 +1685,87 @@ module Unsafe = struct end -let safe_extend ~warning (e : 'a Entry.t) pos - (r : - (string option * Gramext.g_assoc option * 'a ty_production list) - list) = - extend_entry ~warning e pos r +type 'a single_extend_statement = + string option * Gramext.g_assoc option * 'a ty_production list + +type 'a extend_statement = + { pos : Gramext.position option + ; data : 'a single_extend_statement list + } -let safe_delete_rule e r = +let safe_extend (e : 'a Entry.t) { pos; data } = + extend_entry e pos data + +let safe_delete_rule e (TProd (r,_act)) = let AnyS (symbols, _) = get_symbols r in delete_rule e symbols +let level_of_nonterm sym = match sym with + | Snterml (_,l) -> Some l + | _ -> None + +exception SelfSymbol + +let rec generalize_symbol : + type a tr s. (s, tr, a) Symbol.t -> (s, norec, a) ty_symbol = + function + | Stoken tok -> + Stoken tok + | Slist1 e -> + Slist1 (generalize_symbol e) + | Slist1sep (e, sep, b) -> + let e = generalize_symbol e in + let sep = generalize_symbol sep in + Slist1sep (e, sep, b) + | Slist0 e -> + Slist0 (generalize_symbol e) + | Slist0sep (e, sep, b) -> + let e = generalize_symbol e in + let sep = generalize_symbol sep in + Slist0sep (e, sep, b) + | Sopt e -> + Sopt (generalize_symbol e) + | Sself -> + raise SelfSymbol + | Snext -> + raise SelfSymbol + | Snterm e -> + Snterm e + | Snterml (e, l) -> + Snterml (e, l) + | Stree r -> + Stree (generalize_tree r) +and generalize_tree : type a tr s . + (s, tr, a) ty_tree -> (s, norec, a) ty_tree = fun r -> + match r with + | Node (fi, n) -> + let fi = match fi with + | NoRec3 -> NoRec3 + | MayRec3 -> raise SelfSymbol + in + let n = match n with + | { node; son; brother } -> + let node = generalize_symbol node in + let son = generalize_tree son in + let brother = generalize_tree brother in + { node; son; brother } + in + Node (fi, n) + | LocAct _ as r -> r + | DeadEnd as r -> r + +let generalize_symbol s = + try Some (generalize_symbol s) + with SelfSymbol -> None + +let rec mk_rule tok = + match tok with + | [] -> + let stop_e = Rule.stop in + TRules (stop_e, fun _ -> (* dropped anyway: *) "") + | tkn :: rem -> + let TRules (r, f) = mk_rule rem in + let r = Rule.next_norec r (Symbol.token tkn) in + TRules (r, fun _ -> f) + end diff --git a/gramlib/grammar.mli b/gramlib/grammar.mli index f0423a92af..33006f6f65 100644 --- a/gramlib/grammar.mli +++ b/gramlib/grammar.mli @@ -15,8 +15,7 @@ rule "an entry cannot call an entry of another grammar" by normal OCaml typing. *) -module type GLexerType = Plexing.Lexer - (** The input signature for the functor [Grammar.GMake]: [te] is the +(** The input signature for the functor [Grammar.GMake]: [te] is the type of the tokens. *) type norec @@ -29,6 +28,7 @@ module type S = sig module Parsable : sig type t val make : ?loc:Loc.t -> char Stream.t -> t + val comments : t -> ((int * int) * string) list end val tokens : string -> (string option * int) list @@ -36,6 +36,7 @@ module type S = sig module Entry : sig type 'a t val make : string -> 'a t + val create : string -> 'a t (* compat *) val parse : 'a t -> Parsable.t -> 'a val name : 'a t -> string val of_parser : string -> (Plexing.location_function -> te Stream.t -> 'a) -> 'a t @@ -60,7 +61,7 @@ module type S = sig val self : ('self, mayrec, 'self) t val next : ('self, mayrec, 'self) t val token : 'c pattern -> ('self, norec, 'c) t - val rules : warning:(string -> unit) option -> 'a Rules.t list -> ('self, norec, 'a) t + val rules : 'a Rules.t list -> ('self, norec, 'a) t end and Rule : sig @@ -86,17 +87,37 @@ module type S = sig val make : ('a, _, 'f, Loc.t -> 'a) Rule.t -> 'f -> 'a t end - module Unsafe : - sig + type 'a single_extend_statement = + string option * Gramext.g_assoc option * 'a Production.t list + + type 'a extend_statement = + { pos : Gramext.position option + ; data : 'a single_extend_statement list + } + + val generalize_symbol : ('a, 'tr, 'c) Symbol.t -> ('a, norec, 'c) Symbol.t option + + val mk_rule : 'a pattern list -> string Rules.t + + (* Used in custom entries, should tweak? *) + val level_of_nonterm : ('a, norec, 'c) Symbol.t -> string option + +end + +(* Interface private to clients *) +module type ExtS = sig + + include S + + val safe_extend : 'a Entry.t -> 'a extend_statement -> unit + val safe_delete_rule : 'a Entry.t -> 'a Production.t -> unit + + module Unsafe : sig val clear_entry : 'a Entry.t -> unit end - val safe_extend : warning:(string -> unit) option -> - 'a Entry.t -> Gramext.position option -> - (string option * Gramext.g_assoc option * 'a Production.t list) - list -> - unit - val safe_delete_rule : 'a Entry.t -> ('a, _, 'f, 'r) Rule.t -> unit + end + (** Signature type of the functor [Grammar.GMake]. The types and functions are almost the same than in generic interface, but: - Grammars are not values. Functions holding a grammar as parameter @@ -107,5 +128,4 @@ end type (instead of (string * string)); the module parameter must specify a way to show them as (string * string) *) -module GMake (L : GLexerType) : - S with type te = L.te and type 'c pattern = 'c L.pattern +module GMake (L : Plexing.S) : ExtS with type te = L.te and type 'c pattern = 'c L.pattern diff --git a/gramlib/plexing.ml b/gramlib/plexing.ml index e881ab3350..ce3e38ff08 100644 --- a/gramlib/plexing.ml +++ b/gramlib/plexing.ml @@ -5,7 +5,7 @@ type location_function = int -> Loc.t type 'te lexer_func = ?loc:Loc.t -> char Stream.t -> 'te Stream.t * location_function -module type Lexer = sig +module type S = sig type te type 'c pattern val tok_pattern_eq : 'a pattern -> 'b pattern -> ('a, 'b) Util.eq option @@ -15,4 +15,15 @@ module type Lexer = sig val tok_removing : 'c pattern -> unit val tok_match : 'c pattern -> te -> 'c val tok_text : 'c pattern -> string + + (* State for the comments, at some point we should make it functional *) + module State : sig + type t + val init : unit -> t + val set : t -> unit + val get : unit -> t + val drop : unit -> unit + val get_comments : t -> ((int * int) * string) list + end + end diff --git a/gramlib/plexing.mli b/gramlib/plexing.mli index 521eba7446..0c190af635 100644 --- a/gramlib/plexing.mli +++ b/gramlib/plexing.mli @@ -15,7 +15,7 @@ and location_function = int -> Loc.t (** The type of a function giving the location of a token in the source from the token number in the stream (starting from zero). *) -module type Lexer = sig +module type S = sig type te type 'c pattern val tok_pattern_eq : 'a pattern -> 'b pattern -> ('a, 'b) Util.eq option @@ -25,4 +25,15 @@ module type Lexer = sig val tok_removing : 'c pattern -> unit val tok_match : 'c pattern -> te -> 'c val tok_text : 'c pattern -> string + + (* State for the comments, at some point we should make it functional *) + module State : sig + type t + val init : unit -> t + val set : t -> unit + val get : unit -> t + val drop : unit -> unit + val get_comments : t -> ((int * int) * string) list + end + end diff --git a/ide/coq_commands.ml b/ide/coq_commands.ml index c5883cef0d..711986c2b2 100644 --- a/ide/coq_commands.ml +++ b/ide/coq_commands.ml @@ -207,7 +207,6 @@ let state_preserving = [ "Recursive Extraction Library"; "Search"; - "SearchAbout (* deprecated *)"; "SearchHead"; "SearchPattern"; "SearchRewrite"; diff --git a/ide/default_bindings_src.ml b/ide/default_bindings_src.ml index 85a635a50f..a69a7c2aba 100644 --- a/ide/default_bindings_src.ml +++ b/ide/default_bindings_src.ml @@ -545,7 +545,7 @@ let bindings_set_1 = [ ["\\Hopf"; "\\quaternions" ], "ℍ", [letter]; ["\\planckh" ], "ℎ", [letter]; ["\\hslash"; "\\plankv" ], "ℏ", [letter]; - ["\\hbar"; "\\planck" ], "ℏ︀", [letter]; + ["\\hbar"; "\\planck" ], "ℏ", [letter]; ["\\Iscr"; "\\imagline" ], "ℐ", [letter]; ["\\Im"; "\\Ifr"; "\\image"; "\\imagpart" ], "ℑ", [letter]; ["\\Lscr"; "\\lagran"; "\\Laplacetrf" ], "ℒ", [letter]; @@ -1108,7 +1108,7 @@ let bindings_set_1 = [ ["\\isins" ], "⋴", [set]; ["\\isindot" ], "⋵", [set]; ["\\notinvc" ], "⋶", [set]; - ["\\notindot" ], "⋶︀", [set]; + ["\\notindot" ], "⋶", [set]; ["\\notinvb" ], "⋷", [set]; ["\\isinE" ], "⋹", [set]; ["\\nisd" ], "⋺", [set]; @@ -1192,40 +1192,40 @@ let bindings_set_1 = [ (* }}} *) (* {{{ Missing font *) - ["\\NegativeThickSpace" ], " ︀", [miscellanea]; - ["\\NegativeThinSpace" ], " ︀", [miscellanea]; - ["\\NegativeVeryThinSpace" ], " ︀", [miscellanea]; - ["\\NegativeMediumSpace" ], " ︀", [miscellanea]; - ["\\slarr"; "\\ShortLeftArrow" ], "←︀", [miscellanea]; - ["\\srarr"; "\\ShortRightArrow" ], "→︀", [miscellanea]; - ["\\empty"; "\\emptyset" ], "∅︀", [miscellanea]; - ["\\ssetmn"; "\\smallsetminus" ], "∖︀", [miscellanea]; - ["\\smid"; "\\shortmid" ], "∣︀", [miscellanea]; - ["\\nsmid"; "\\nshortmid" ], "∤︀", [miscellanea]; - ["\\spar"; "\\parsl"; "\\shortparallel" ], "∥︀", [miscellanea]; - ["\\nparsl" ], "∥︀⃥", [miscellanea]; - ["\\nspar"; "\\nshortparallel" ], "∦︀", [miscellanea]; - ["\\caps" ], "∩︀", [miscellanea]; - ["\\cups" ], "∪︀", [miscellanea]; - ["\\thksim"; "\\thicksim" ], "∼︀", [miscellanea]; - ["\\thkap"; "\\thickapprox" ], "≈︀", [miscellanea]; - ["\\nedot" ], "≠︀", [miscellanea]; + ["\\NegativeThickSpace" ], " ", [miscellanea]; + ["\\NegativeThinSpace" ], " ", [miscellanea]; + ["\\NegativeVeryThinSpace" ], " ", [miscellanea]; + ["\\NegativeMediumSpace" ], " ", [miscellanea]; + ["\\slarr"; "\\ShortLeftArrow" ], "←", [miscellanea]; + ["\\srarr"; "\\ShortRightArrow" ], "→", [miscellanea]; + ["\\empty"; "\\emptyset" ], "∅", [miscellanea]; + ["\\ssetmn"; "\\smallsetminus" ], "∖", [miscellanea]; + ["\\smid"; "\\shortmid" ], "∣", [miscellanea]; + ["\\nsmid"; "\\nshortmid" ], "∤", [miscellanea]; + ["\\spar"; "\\parsl"; "\\shortparallel" ], "∥", [miscellanea]; + ["\\nparsl" ], "∥⃥", [miscellanea]; + ["\\nspar"; "\\nshortparallel" ], "∦", [miscellanea]; + ["\\caps" ], "∩", [miscellanea]; + ["\\cups" ], "∪", [miscellanea]; + ["\\thksim"; "\\thicksim" ], "∼", [miscellanea]; + ["\\thkap"; "\\thickapprox" ], "≈", [miscellanea]; + ["\\nedot" ], "≠", [miscellanea]; ["\\bnequiv" ], "≡⃥", [miscellanea]; - ["\\lvnE"; "\\lvertneqq" ], "≨︀", [miscellanea]; - ["\\gvnE"; "\\gvertneqq" ], "≩︀", [miscellanea]; - ["\\nLtv"; "\\NotLessLess" ], "≪̸︀", [miscellanea]; - ["\\nGtv"; "\\NotGreaterGreater" ], "≫̸︀", [miscellanea]; + ["\\lvnE"; "\\lvertneqq" ], "≨", [miscellanea]; + ["\\gvnE"; "\\gvertneqq" ], "≩", [miscellanea]; + ["\\nLtv"; "\\NotLessLess" ], "≪̸", [miscellanea]; + ["\\nGtv"; "\\NotGreaterGreater" ], "≫̸", [miscellanea]; ["\\nle"; "\\NotLessEqual" ], "≰⃥", [miscellanea]; ["\\nge"; "\\NotGreaterEqual" ], "≱⃥", [miscellanea]; - ["\\vsubnE"; "\\vsubne"; "\\varsubsetneq"; "\\varsubsetneqq" ], "⊊︀", [miscellanea]; - ["\\vsupne"; "\\vsupnE"; "\\varsupsetneq"; "\\varsupsetneqq" ], "⊋︀", [miscellanea]; - ["\\sqcaps" ], "⊓︀", [miscellanea]; - ["\\sqcups" ], "⊔︀", [miscellanea]; + ["\\vsubnE"; "\\vsubne"; "\\varsubsetneq"; "\\varsubsetneqq" ], "⊊", [miscellanea]; + ["\\vsupne"; "\\vsupnE"; "\\varsupsetneq"; "\\varsupsetneqq" ], "⊋", [miscellanea]; + ["\\sqcaps" ], "⊓", [miscellanea]; + ["\\sqcups" ], "⊔", [miscellanea]; ["\\prurel" ], "⊰", [miscellanea]; - ["\\lesg" ], "⋚︀", [miscellanea]; - ["\\gesl" ], "⋛︀", [miscellanea]; - ["\\ShortUpArrow" ], "⌃︀", [miscellanea]; - ["\\ShortDownArrow" ], "⌄︀", [miscellanea]; + ["\\lesg" ], "⋚", [miscellanea]; + ["\\gesl" ], "⋛", [miscellanea]; + ["\\ShortUpArrow" ], "⌃", [miscellanea]; + ["\\ShortDownArrow" ], "⌄", [miscellanea]; ["\\target" ], "⌖", [miscellanea]; ["\\cylcty" ], "⌭", [miscellanea]; ["\\profalar" ], "⌮", [miscellanea]; @@ -1248,7 +1248,7 @@ let bindings_set_1 = [ ["\\ltrPar" ], "⦖", [miscellanea]; ["\\vzigzag" ], "⦚", [miscellanea]; ["\\angrtvbd" ], "⦝", [miscellanea]; - ["\\angrtvb" ], "⦝︀", [miscellanea]; + ["\\angrtvb" ], "⦝", [miscellanea]; ["\\ange" ], "⦤", [miscellanea]; ["\\range" ], "⦥", [miscellanea]; ["\\dwangle" ], "⦦", [miscellanea]; @@ -1367,9 +1367,9 @@ let bindings_set_1 = [ ["\\smt" ], "⪪", [miscellanea]; ["\\lat" ], "⪫", [miscellanea]; ["\\smte" ], "⪬", [miscellanea]; - ["\\smtes" ], "⪬︀", [miscellanea]; + ["\\smtes" ], "⪬", [miscellanea]; ["\\late" ], "⪭", [miscellanea]; - ["\\lates" ], "⪭︀", [miscellanea]; + ["\\lates" ], "⪭", [miscellanea]; ["\\Sc" ], "⪼", [miscellanea]; ["\\subdot" ], "⪽", [miscellanea]; ["\\supdot" ], "⪾", [miscellanea]; diff --git a/ide/microPG.ml b/ide/microPG.ml index 46d3316ef6..5a4871b70a 100644 --- a/ide/microPG.ml +++ b/ide/microPG.ml @@ -289,7 +289,6 @@ let pg = insert pg "Proof General" [mC,_c,"c"; mC,_a,"a"] [ mkE _p "p" "Print" (Callback (fun gui -> command gui "Print")); mkE _c "c" "Check" (Callback (fun gui -> command gui "Check")); mkE _b "b" "About" (Callback (fun gui -> command gui "About")); - mkE _a "a" "Search About" (Callback (fun gui -> command gui "SearchAbout")); mkE _o "o" "Search Pattern" (Callback (fun gui->command gui "SearchPattern")); mkE _l "l" "Locate" (Callback (fun gui -> command gui "Locate")); mkE _Return "RET" "match template" (Action("Templates","match")); diff --git a/interp/constrexpr.ml b/interp/constrexpr.ml index 8732b0e2c6..21f682ac0e 100644 --- a/interp/constrexpr.ml +++ b/interp/constrexpr.ml @@ -57,26 +57,8 @@ type abstraction_kind = AbsLambda | AbsPi type proj_flag = int option (** [Some n] = proj of the n-th visible argument *) -(** Representation of decimal literals that appear in Coq scripts. - We now use raw strings following the format defined by - [NumTok.t] and a separate sign flag. - - Note that this representation is not unique, due to possible - multiple leading or trailing zeros, and -0 = +0, for instances. - The reason to keep the numeral exactly as it was parsed is that - specific notations can be declared for specific numerals - (e.g. [Notation "0" := False], or [Notation "00" := (nil,nil)], or - [Notation "2e1" := ...]). Those notations, which override the - generic interpretation as numeral, use the same representation of - numeral using the Numeral constructor. So the latter should be able - to record the form of the numeral which exactly matches the - notation. *) - -type sign = SPlus | SMinus -type raw_numeral = NumTok.t - type prim_token = - | Numeral of sign * raw_numeral + | Numeral of NumTok.Signed.t | String of string type instance_expr = Glob_term.glob_level list diff --git a/interp/constrexpr_ops.ml b/interp/constrexpr_ops.ml index da5b8d9132..d4369e9bd1 100644 --- a/interp/constrexpr_ops.ml +++ b/interp/constrexpr_ops.ml @@ -48,10 +48,9 @@ let names_of_local_binders bl = are considered different here. *) let prim_token_eq t1 t2 = match t1, t2 with -| Numeral (SPlus,n1), Numeral (SPlus,n2) -| Numeral (SMinus,n1), Numeral (SMinus,n2) -> NumTok.equal n1 n2 +| Numeral n1, Numeral n2 -> NumTok.Signed.equal n1 n2 | String s1, String s2 -> String.equal s1 s2 -| (Numeral ((SPlus|SMinus),_) | String _), _ -> false +| (Numeral _ | String _), _ -> false let explicitation_eq ex1 ex2 = match ex1, ex2 with | ExplByPos (i1, id1), ExplByPos (i2, id2) -> diff --git a/interp/constrextern.ml b/interp/constrextern.ml index a16825b5c9..7a14ca3e48 100644 --- a/interp/constrextern.ml +++ b/interp/constrextern.ml @@ -354,27 +354,21 @@ let drop_implicits_in_patt cst nb_expl args = let destPrim = function { CAst.v = CPrim t } -> Some t | _ -> None let destPatPrim = function { CAst.v = CPatPrim t } -> Some t | _ -> None -let is_zero s = - let rec aux i = - Int.equal (String.length s) i || (s.[i] == '0' && aux (i+1)) - in aux 0 -let is_zero n = is_zero n.NumTok.int && is_zero n.NumTok.frac - let make_notation_gen loc ntn mknot mkprim destprim l bl = match snd ntn,List.map destprim l with (* Special case to avoid writing "- 3" for e.g. (Z.opp 3) *) - | "- _", [Some (Numeral (SPlus,p))] when not (is_zero p) -> + | "- _", [Some (Numeral p)] when not (NumTok.Signed.is_zero p) -> assert (bl=[]); mknot (loc,ntn,([mknot (loc,(InConstrEntrySomeLevel,"( _ )"),l,[])]),[]) | _ -> match decompose_notation_key ntn, l with | (InConstrEntrySomeLevel,[Terminal "-"; Terminal x]), [] -> - begin match NumTok.of_string x with - | Some n -> mkprim (loc, Numeral (SMinus,n)) + begin match NumTok.Unsigned.parse_string x with + | Some n -> mkprim (loc, Numeral (NumTok.SMinus,n)) | None -> mknot (loc,ntn,l,bl) end | (InConstrEntrySomeLevel,[Terminal x]), [] -> - begin match NumTok.of_string x with - | Some n -> mkprim (loc, Numeral (SPlus,n)) + begin match NumTok.Unsigned.parse_string x with + | Some n -> mkprim (loc, Numeral (NumTok.SPlus,n)) | None -> mknot (loc,ntn,l,bl) end | _ -> mknot (loc,ntn,l,bl) @@ -899,13 +893,10 @@ let extern_float f scopes = else if Float64.is_infinity f then CRef(q_infinity (), None) else if Float64.is_neg_infinity f then CRef(q_neg_infinity (), None) else - let sign = if Float64.sign f then SMinus else SPlus in - let s = Float64.(to_string (abs f)) in - match NumTok.of_string s with - | None -> assert false - | Some n -> - extern_prim_token_delimiter_if_required (Numeral (sign, n)) - "float" "float_scope" scopes + let s = Float64.(to_string f) in + let n = NumTok.Signed.of_string s in + extern_prim_token_delimiter_if_required (Numeral n) + "float" "float_scope" scopes (**********************************************************************) (* mapping glob_constr to constr_expr *) @@ -1085,7 +1076,7 @@ let rec extern inctx ?impargs scopes vars r = | GInt i -> extern_prim_token_delimiter_if_required - (Numeral (SPlus, NumTok.int (Uint63.to_string i))) + (Numeral (NumTok.Signed.of_int_string (Uint63.to_string i))) "int63" "int63_scope" (snd scopes) | GFloat f -> extern_float f (snd scopes) diff --git a/interp/constrintern.ml b/interp/constrintern.ml index abacadc43a..a071ba7ec9 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -32,6 +32,7 @@ open Notation_ops open Notation open Inductiveops open Context.Rel.Declaration +open NumTok (** constr_expr -> glob_constr translation: - it adds holes for implicit arguments @@ -1585,12 +1586,6 @@ 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' || s.[i] == '_') && aux (i+1)) - in aux 0 -let is_zero n = is_zero n.NumTok.int && is_zero n.NumTok.frac - let merge_subst s1 s2 = Id.Map.fold Id.Map.add s1 s2 let product_of_cases_patterns aliases idspl = @@ -1614,11 +1609,11 @@ let rec subst_pat_iterator y t = DAst.(map (function | RCPatOr pl -> RCPatOr (List.map (subst_pat_iterator y t) pl))) let is_non_zero c = match c with -| { CAst.v = CPrim (Numeral (SPlus, p)) } -> not (is_zero p) +| { CAst.v = CPrim (Numeral p) } -> not (NumTok.Signed.is_zero p) | _ -> false let is_non_zero_pat c = match c with -| { CAst.v = CPatPrim (Numeral (SPlus, p)) } -> not (is_zero p) +| { CAst.v = CPatPrim (Numeral p) } -> not (NumTok.Signed.is_zero p) | _ -> false let get_asymmetric_patterns = Goptions.declare_bool_option_and_ref diff --git a/interp/notation.ml b/interp/notation.ml index 4b73189ad3..6291a88bb0 100644 --- a/interp/notation.ml +++ b/interp/notation.ml @@ -21,6 +21,7 @@ open Notation_term open Glob_term open Glob_ops open Context.Named.Declaration +open NumTok (*i*) @@ -335,7 +336,7 @@ let notation_constr_key = function (* Rem: NApp(NRef ref,[]) stands for @ref *) (* Interpreting numbers (not in summary because functional objects) *) type required_module = full_path * string list -type rawnum = Constrexpr.sign * Constrexpr.raw_numeral +type rawnum = NumTok.Signed.t type prim_token_uid = string @@ -358,17 +359,13 @@ module InnerPrimToken = struct | StringInterp f, StringInterp f' -> f == f' | _ -> false - let ofNumeral s n = - let n = String.(concat "" (split_on_char '_' n)) in - match s with - | SPlus -> Bigint.of_string n - | SMinus -> Bigint.neg (Bigint.of_string n) - let do_interp ?loc interp primtok = match primtok, interp with - | Numeral (s,n), RawNumInterp interp -> interp ?loc (s,n) - | Numeral (s,{ NumTok.int = n; frac = ""; exp = "" }), - BigNumInterp interp -> interp ?loc (ofNumeral s n) + | Numeral n, RawNumInterp interp -> interp ?loc n + | Numeral n, BigNumInterp interp -> + (match NumTok.Signed.to_bigint n with + | Some n -> interp ?loc n + | None -> raise Not_found) | String s, StringInterp interp -> interp ?loc s | (Numeral _ | String _), (RawNumInterp _ | BigNumInterp _ | StringInterp _) -> raise Not_found @@ -385,10 +382,7 @@ module InnerPrimToken = struct | _ -> false let mkNumeral n = - if Bigint.is_pos_or_zero n then - Numeral (SPlus,NumTok.int (Bigint.to_string n)) - else - Numeral (SMinus,NumTok.int (Bigint.to_string (Bigint.neg n))) + Numeral (NumTok.Signed.of_bigint n) let mkString = function | None -> None @@ -425,8 +419,8 @@ exception PrimTokenNotationError of string * Environ.env * Evd.evar_map * prim_t type numnot_option = | Nop - | Warning of string - | Abstract of string + | Warning of NumTok.UnsignedNat.t + | Abstract of NumTok.UnsignedNat.t type int_ty = { uint : Names.inductive; @@ -567,7 +561,7 @@ let uninterp to_raw o (Glob_term.AnyGlobConstr n) = Some (to_raw (fst o.of_kind, c)) with | Type_errors.TypeError _ | Pretype_errors.PretypeError _ -> None (* cf. eval_constr_app *) - | NotAValidPrimToken -> None (* all other functions except big2raw *) + | NotAValidPrimToken -> None (* all other functions except NumTok.Signed.of_bigint *) end @@ -600,26 +594,6 @@ let warn_abstract_large_num = pr_qualid ty ++ strbrk " are interpreted as applications of " ++ Nametab.pr_global_env (Termops.vars_of_env (Global.env ())) f ++ strbrk ".") -(** Comparing two raw numbers (base 10, big-endian, non-negative). - A bit nasty, but not critical: only used to decide when a - number is considered as large (see warnings above). *) - -exception Comp of int - -let rec rawnum_compare s s' = - let l = String.length s and l' = String.length s' in - if l < l' then - rawnum_compare s' s - else - let d = l-l' in - try - for i = 0 to d-1 do if s.[i] != '0' then raise (Comp 1) done; - for i = d to l-1 do - let c = pervasives_compare s.[i] s'.[i-d] in - if c != 0 then raise (Comp c) - done; - 0 - with Comp c -> c - (***********************************************************************) (** ** Conversion between Coq [Decimal.int] and internal raw string *) @@ -634,32 +608,31 @@ let char_of_digit n = assert (2<=n && n<=11); Char.chr (n-2 + Char.code '0') -let coquint_of_rawnum uint str = +let coquint_of_rawnum uint n = let nil = mkConstruct (uint,1) in + match n with None -> nil | Some n -> + let str = NumTok.UnsignedNat.to_string n in let rec do_chars s i acc = if i < 0 then acc - else if s.[i] == '_' then do_chars s (i-1) acc else + else let dg = mkConstruct (uint, digit_of_char s.[i]) in do_chars s (i-1) (mkApp(dg,[|acc|])) in do_chars str (String.length str - 1) nil -let coqint_of_rawnum inds sign str = - let uint = coquint_of_rawnum inds.uint str in +let coqint_of_rawnum inds (sign,n) = + let uint = coquint_of_rawnum inds.uint (Some n) in let pos_neg = match sign with SPlus -> 1 | SMinus -> 2 in mkApp (mkConstruct (inds.int, pos_neg), [|uint|]) -let coqdecimal_of_rawnum inds sign n = - let i, f, e = NumTok.(n.int, n.frac, n.exp) in - let i = coqint_of_rawnum inds.int sign i in +let coqdecimal_of_rawnum inds n = + let i, f, e = NumTok.Signed.to_decimal_and_exponent n in + let i = coqint_of_rawnum inds.int i in let f = coquint_of_rawnum inds.int.uint f in - if e = "" then mkApp (mkConstruct (inds.decimal, 1), [|i; f|]) (* Decimal *) - else - let sign, e = match e.[1] with - | '-' -> SMinus, String.sub e 2 (String.length e - 2) - | '+' -> SPlus, String.sub e 2 (String.length e - 2) - | _ -> SPlus, String.sub e 1 (String.length e - 1) in - let e = coqint_of_rawnum inds.int sign e in + match e with + | None -> mkApp (mkConstruct (inds.decimal, 1), [|i; f|]) (* Decimal *) + | Some e -> + let e = coqint_of_rawnum inds.int e in mkApp (mkConstruct (inds.decimal, 2), [|i; f; e|]) (* DecimalExp *) let rawnum_of_coquint c = @@ -680,26 +653,23 @@ let rawnum_of_coquint c = (* To avoid ambiguities between Nil and (D0 Nil), we choose to not display Nil alone as "0" *) raise NotAValidPrimToken - else NumTok.int (Buffer.contents buf) + else NumTok.UnsignedNat.of_string (Buffer.contents buf) let rawnum_of_coqint c = match Constr.kind c with | App (c,[|c'|]) -> (match Constr.kind c with - | Construct ((_,1), _) (* Pos *) -> (SPlus, rawnum_of_coquint c') - | Construct ((_,2), _) (* Neg *) -> (SMinus, rawnum_of_coquint c') + | Construct ((_,1), _) (* Pos *) -> (SPlus,rawnum_of_coquint c') + | Construct ((_,2), _) (* Neg *) -> (SMinus,rawnum_of_coquint c') | _ -> raise NotAValidPrimToken) | _ -> raise NotAValidPrimToken let rawnum_of_decimal c = let of_ife i f e = - let sign, n = rawnum_of_coqint i in - let f = - try (rawnum_of_coquint f).NumTok.int with NotAValidPrimToken -> "" in - let e = match e with None -> "" | Some e -> match rawnum_of_coqint e with - | SPlus, e -> "e+" ^ e.NumTok.int - | SMinus, e -> "e-" ^ e.NumTok.int in - sign,{ n with NumTok.frac = f; exp = e } in + let n = rawnum_of_coqint i in + let f = try Some (rawnum_of_coquint f) with NotAValidPrimToken -> None in + let e = match e with None -> None | Some e -> Some (rawnum_of_coqint e) in + NumTok.Signed.of_decimal_and_exponent n f e in match Constr.kind c with | App (_,[|i; f|]) -> of_ife i f None | App (_,[|i; f; e|]) -> of_ife i f (Some e) @@ -789,43 +759,31 @@ let bigint_of_int63 c = | Int i -> Bigint.of_string (Uint63.to_string i) | _ -> raise NotAValidPrimToken -let big2raw n = - if Bigint.is_pos_or_zero n then - (SPlus, NumTok.int (Bigint.to_string n)) - else - (SMinus, NumTok.int (Bigint.to_string (Bigint.neg n))) - -let raw2big s n = match s with - | SPlus -> Bigint.of_string n - | SMinus -> Bigint.neg (Bigint.of_string n) - let interp o ?loc n = begin match o.warning, n with - | Warning threshold, (SPlus, { NumTok.int = n; frac = ""; exp = "" }) - when rawnum_compare n threshold >= 0 -> + | Warning threshold, n when NumTok.Signed.is_bigger_int_than n threshold -> warn_large_num o.ty_name | _ -> () end; - let c = match fst o.to_kind, n with - | Int int_ty, (s, { NumTok.int = n; frac = ""; exp = "" }) -> - coqint_of_rawnum int_ty s n - | UInt uint_ty, (SPlus, { NumTok.int = n; frac = ""; exp = "" }) -> - coquint_of_rawnum uint_ty n - | Z z_pos_ty, (s, { NumTok.int = n; frac = ""; exp = "" }) -> - z_of_bigint z_pos_ty (raw2big s n) - | Int63, (s, { NumTok.int = n; frac = ""; exp = "" }) -> - interp_int63 ?loc (raw2big s n) + let c = match fst o.to_kind, NumTok.Signed.to_int n with + | Int int_ty, Some n -> + coqint_of_rawnum int_ty n + | UInt uint_ty, Some (SPlus, n) -> + coquint_of_rawnum uint_ty (Some n) + | Z z_pos_ty, Some n -> + z_of_bigint z_pos_ty (NumTok.SignedNat.to_bigint n) + | Int63, Some n -> + interp_int63 ?loc (NumTok.SignedNat.to_bigint n) | (Int _ | UInt _ | Z _ | Int63), _ -> no_such_prim_token "number" ?loc o.ty_name - | Decimal decimal_ty, (s,n) -> coqdecimal_of_rawnum decimal_ty s n + | Decimal decimal_ty, _ -> coqdecimal_of_rawnum decimal_ty n in let env = Global.env () in let sigma = Evd.from_env env in let sigma,to_ty = Evd.fresh_global env sigma o.to_ty in let to_ty = EConstr.Unsafe.to_constr to_ty in match o.warning, snd o.to_kind with - | Abstract threshold, Direct - when rawnum_compare (snd n).NumTok.int threshold >= 0 -> + | Abstract threshold, Direct when NumTok.Signed.is_bigger_int_than n threshold -> warn_abstract_large_num (o.ty_name,o.to_ty); glob_of_constr "numeral" ?loc env sigma (mkApp (to_ty,[|c|])) | _ -> @@ -837,10 +795,10 @@ let interp o ?loc n = let uninterp o n = PrimTokenNotation.uninterp begin function - | (Int _, c) -> rawnum_of_coqint c - | (UInt _, c) -> (SPlus, rawnum_of_coquint c) - | (Z _, c) -> big2raw (bigint_of_z c) - | (Int63, c) -> big2raw (bigint_of_int63 c) + | (Int _, c) -> NumTok.Signed.of_int (rawnum_of_coqint c) + | (UInt _, c) -> NumTok.Signed.of_nat (rawnum_of_coquint c) + | (Z _, c) -> NumTok.Signed.of_bigint (bigint_of_z c) + | (Int63, c) -> NumTok.Signed.of_bigint (bigint_of_int63 c) | (Decimal _, c) -> rawnum_of_decimal c end o n end @@ -1162,8 +1120,8 @@ let find_notation ntn sc = NotationMap.find ntn (find_scope sc).notations let notation_of_prim_token = function - | Numeral (SPlus,n) -> InConstrEntrySomeLevel, NumTok.to_string n - | Numeral (SMinus,n) -> InConstrEntrySomeLevel, "- "^NumTok.to_string n + | Numeral (SPlus,n) -> InConstrEntrySomeLevel, NumTok.Unsigned.sprint n + | Numeral (SMinus,n) -> InConstrEntrySomeLevel, "- "^NumTok.Unsigned.sprint n | String _ -> raise Not_found let find_prim_token check_allowed ?loc p sc = diff --git a/interp/notation.mli b/interp/notation.mli index 8fcf9dc5dc..892eba8d11 100644 --- a/interp/notation.mli +++ b/interp/notation.mli @@ -81,7 +81,7 @@ val find_delimiters_scope : ?loc:Loc.t -> delimiters -> scope_name type notation_location = (DirPath.t * DirPath.t) * string type required_module = full_path * string list -type rawnum = Constrexpr.sign * Constrexpr.raw_numeral +type rawnum = NumTok.Signed.t (** The unique id string below will be used to refer to a particular registered interpreter/uninterpreter of numeral or string notation. @@ -116,8 +116,8 @@ exception PrimTokenNotationError of string * Environ.env * Evd.evar_map * prim_t type numnot_option = | Nop - | Warning of string - | Abstract of string + | Warning of NumTok.UnsignedNat.t + | Abstract of NumTok.UnsignedNat.t type int_ty = { uint : Names.inductive; diff --git a/interp/numTok.ml b/interp/numTok.ml index c11acdc8bd..e254e9e972 100644 --- a/interp/numTok.ml +++ b/interp/numTok.ml @@ -8,55 +8,243 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -type t = { - int : string; - frac : string; - exp : string -} - -let equal n1 n2 = - String.(equal n1.int n2.int && equal n1.frac n2.frac && equal n1.exp n2.exp) - -let int s = { int = s; frac = ""; exp = "" } - -let to_string n = n.int ^ (if n.frac = "" then "" else "." ^ n.frac) ^ n.exp - -let parse = - let buff = ref (Bytes.create 80) in - let store len x = - let open Bytes in - if len >= length !buff then - buff := cat !buff (create (length !buff)); - set !buff len x; - succ len in - let get_buff len = Bytes.sub_string !buff 0 len in - (* reads [0-9_]* *) - let rec number len s = match Stream.peek s with - | Some (('0'..'9' | '_') as c) -> Stream.junk s; number (store len c) s - | _ -> len in - fun s -> - let i = get_buff (number 0 s) in - let f = - match Stream.npeek 2 s with - | '.' :: (('0'..'9' | '_') as c) :: _ -> - Stream.junk s; Stream.junk s; get_buff (number (store 0 c) s) - | _ -> "" in - let e = - match (Stream.npeek 2 s) with - | (('e'|'E') as e) :: ('0'..'9' as c) :: _ -> - Stream.junk s; Stream.junk s; get_buff (number (store (store 0 e) c) s) - | (('e'|'E') as e) :: (('+'|'-') as sign) :: _ -> - begin match Stream.npeek 3 s with - | _ :: _ :: ('0'..'9' as c) :: _ -> - Stream.junk s; Stream.junk s; Stream.junk s; - get_buff (number (store (store (store 0 e) sign) c) s) - | _ -> "" - end - | _ -> "" in - { int = i; frac = f; exp = e } - -let of_string s = - if s = "" || s.[0] < '0' || s.[0] > '9' then None else - let strm = Stream.of_string (s ^ " ") in - let n = parse strm in - if Stream.count strm >= String.length s then Some n else None +(** We keep the string to preserve the user representation, + e.g. "e"/"E" or the presence of leading 0s, or the presence of a + + in the exponent *) + +module UnsignedNat = +struct + type t = string + let of_string s = + assert (String.length s > 0); + assert (s.[0] >= '0' && s.[0] <= '9'); + s + let to_string s = + String.(concat "" (split_on_char '_' s)) + + let sprint s = s + let print s = Pp.str (sprint s) + + (** Comparing two raw numbers (base 10, big-endian, non-negative). + A bit nasty, but not critical: used e.g. to decide when a number + is considered as large (see threshold warnings in notation.ml). *) + + exception Comp of int + + let rec compare s s' = + let l = String.length s and l' = String.length s' in + if l < l' then - compare s' s + else + let d = l-l' in + try + for i = 0 to d-1 do if s.[i] != '0' then raise (Comp 1) done; + for i = d to l-1 do + let c = Util.pervasives_compare s.[i] s'.[i-d] in + if c != 0 then raise (Comp c) + done; + 0 + with Comp c -> c + + let is_zero s = + compare s "0" = 0 +end + +type sign = SPlus | SMinus + +module SignedNat = +struct + type t = sign * UnsignedNat.t + let of_string s = + assert (String.length s > 0); + let sign,n = + match s.[0] with + | '-' -> (SMinus,String.sub s 1 (String.length s - 1)) + | '+' -> (SPlus,String.sub s 1 (String.length s - 1)) + | _ -> (SPlus,s) in + (sign,UnsignedNat.of_string n) + let to_string (sign,n) = + (match sign with SPlus -> "" | SMinus -> "-") ^ UnsignedNat.to_string n + let to_bigint n = Bigint.of_string (to_string n) + let of_bigint n = + let sign, n = if Bigint.is_strictly_neg n then (SMinus, Bigint.neg n) else (SPlus, n) in + (sign, Bigint.to_string n) +end + +module Unsigned = +struct + + type t = { + int : string; (** \[0-9\]\[0-9_\]* *) + frac : string; (** empty or \[0-9_\]+ *) + exp : string (** empty or \[eE\]\[+-\]?\[0-9\]\[0-9_\]* *) + } + + let equal n1 n2 = + String.(equal n1.int n2.int && equal n1.frac n2.frac && equal n1.exp n2.exp) + + let parse = + let buff = ref (Bytes.create 80) in + let store len x = + let open Bytes in + if len >= length !buff then + buff := cat !buff (create (length !buff)); + set !buff len x; + succ len in + let get_buff len = Bytes.sub_string !buff 0 len in + (* reads [0-9_]* *) + let rec number len s = match Stream.peek s with + | Some ('0'..'9' as c) -> Stream.junk s; number (store len c) s + | Some ('_' as c) when len > 0 -> Stream.junk s; number (store len c) s + | _ -> len in + fun s -> + let i = get_buff (number 0 s) in + assert (i <> ""); + let f = + match Stream.npeek 2 s with + | '.' :: (('0'..'9' | '_') as c) :: _ -> + Stream.junk s; Stream.junk s; get_buff (number (store 0 c) s) + | _ -> "" in + let e = + match (Stream.npeek 2 s) with + | (('e'|'E') as e) :: ('0'..'9' as c) :: _ -> + Stream.junk s; Stream.junk s; get_buff (number (store (store 0 e) c) s) + | (('e'|'E') as e) :: (('+'|'-') as sign) :: _ -> + begin match Stream.npeek 3 s with + | _ :: _ :: ('0'..'9' as c) :: _ -> + Stream.junk s; Stream.junk s; Stream.junk s; + get_buff (number (store (store (store 0 e) sign) c) s) + | _ -> "" + end + | _ -> "" in + { int = i; frac = f; exp = e } + + let sprint n = + n.int ^ (if n.frac = "" then "" else "." ^ n.frac) ^ n.exp + + let print n = + Pp.str (sprint n) + + let parse_string s = + if s = "" || s.[0] < '0' || s.[0] > '9' then None else + let strm = Stream.of_string (s ^ " ") in + let n = parse strm in + if Stream.count strm >= String.length s then Some n else None + + let of_string s = + match parse_string s with + | None -> assert false + | Some s -> s + + let to_string = + sprint (* We could remove the '_' but not necessary for float_of_string *) + + let to_nat = function + | { int = i; frac = ""; exp = "" } -> Some i + | _ -> None + + let is_nat = function + | { int = _; frac = ""; exp = "" } -> true + | _ -> false + +end + +open Unsigned + +module Signed = +struct + + type t = sign * Unsigned.t + + let equal (s1,n1) (s2,n2) = + s1 = s2 && equal n1 n2 + + let is_zero = function + | (SPlus,{int;frac;exp}) -> UnsignedNat.is_zero int && UnsignedNat.is_zero frac + | _ -> false + + let of_decimal_and_exponent (sign,int) f e = + let exp = match e with Some e -> "e" ^ SignedNat.to_string e | None -> "" in + let frac = match f with Some f -> UnsignedNat.to_string f | None -> "" in + sign, { int; frac; exp } + + let to_decimal_and_exponent (sign, { int; frac; exp }) = + let e = + if exp = "" then None else + Some (match exp.[1] with + | '-' -> SMinus, String.sub exp 2 (String.length exp - 2) + | '+' -> SPlus, String.sub exp 2 (String.length exp - 2) + | _ -> SPlus, String.sub exp 1 (String.length exp - 1)) in + let f = if frac = "" then None else Some frac in + (sign, int), f, e + + let of_nat i = + (SPlus,{ int = i; frac = ""; exp = "" }) + + let of_int (s,i) = + (s,{ int = i; frac = ""; exp = "" }) + + let of_int_string s = of_int (SignedNat.of_string s) + + let to_int = function + | (s, { int = i; frac = ""; exp = "" }) -> Some (s,i) + | _ -> None + + let is_int n = match to_int n with None -> false | Some _ -> true + + let sprint (s,i) = + (match s with SPlus -> "" | SMinus -> "-") ^ Unsigned.sprint i + + let print i = + Pp.str (sprint i) + + let parse_string s = + if s = "" || s = "-" || s = "+" || + (s.[0] < '0' || s.[0] > '9') && ((s.[0] <> '-' && s.[0] <> '+') || s.[1] < '0' || s.[1] > '9') then None else + let strm = Stream.of_string (s ^ " ") in + let sign = match s.[0] with + | '-' -> (Stream.junk strm; SMinus) + | '+' -> (Stream.junk strm; SPlus) + | _ -> SPlus in + let n = parse strm in + if Stream.count strm >= String.length s then Some (sign,n) else None + + let of_string s = + assert (s <> ""); + let sign,u = match s.[0] with + | '-' -> (SMinus, String.sub s 1 (String.length s - 1)) + | '+' -> (SPlus, String.sub s 1 (String.length s - 1)) + | _ -> (SPlus, s) in + (sign, Unsigned.of_string u) + + let to_string (sign,u) = + (match sign with SPlus -> "" | SMinus -> "-") ^ Unsigned.to_string u + + let to_bigint = function + | (sign, { int = n; frac = ""; exp = "" }) -> + Some (SignedNat.to_bigint (sign,UnsignedNat.to_string n)) + | _ -> None + + let of_bigint n = + let sign, int = SignedNat.of_bigint n in + (sign, { int; frac = ""; exp = "" }) + + let to_bigint_and_exponent (s, { int; frac; exp }) = + let s = match s with SPlus -> "" | SMinus -> "-" in + let int = UnsignedNat.to_string int in + let frac = UnsignedNat.to_string frac in + let i = Bigint.of_string (s ^ int ^ frac) in + let e = + let e = if exp = "" then Bigint.zero else match exp.[1] with + | '+' -> Bigint.of_string (UnsignedNat.to_string (String.sub exp 2 (String.length exp - 2))) + | '-' -> Bigint.(neg (of_string (UnsignedNat.to_string (String.sub exp 2 (String.length exp - 2))))) + | _ -> Bigint.of_string (UnsignedNat.to_string (String.sub exp 1 (String.length exp - 1))) in + Bigint.(sub e (of_int (String.length (String.concat "" (String.split_on_char '_' frac))))) in + (i,e) + + let of_bigint_and_exponent i e = + of_decimal_and_exponent (SignedNat.of_bigint i) None (Some (SignedNat.of_bigint e)) + + let is_bigger_int_than (s, { int; frac; exp }) i = + frac = "" && exp = "" && UnsignedNat.compare int i >= 0 + +end diff --git a/interp/numTok.mli b/interp/numTok.mli index 141f1be889..ea289df237 100644 --- a/interp/numTok.mli +++ b/interp/numTok.mli @@ -8,21 +8,125 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -type t = { - int : string; (** \[0-9\]\[0-9_\]* *) - frac : string; (** empty or \[0-9_\]+ *) - exp : string (** empty or \[eE\]\[+-\]?\[0-9\]\[0-9_\]* *) -} +(** Numerals in different forms: signed or unsigned, possibly with + fractional part and exponent. -val equal : t -> t -> bool + Numerals are represented using raw strings of decimal + literals and a separate sign flag. -(** [int s] amounts to [\{ int = s; frac = ""; exp = "" \}] *) -val int : string -> t + Note that this representation is not unique, due to possible + multiple leading or trailing zeros, and -0 = +0, for instances. + The reason to keep the numeral exactly as it was parsed is that + specific notations can be declared for specific numerals + (e.g. [Notation "0" := False], or [Notation "00" := (nil,nil)], or + [Notation "2e1" := ...]). Those notations override the generic + interpretation as numeral. So, one has to record the form of the + numeral which exactly matches the notation. *) -val to_string : t -> string +type sign = SPlus | SMinus -val of_string : string -> t option +(** {6 String representation of a natural number } *) -(** Precondition: the first char on the stream is a digit (\[0-9\]). - Precondition: at least two extra chars after the numeral to parse. *) -val parse : char Stream.t -> t +module UnsignedNat : +sig + type t + val of_string : string -> t + (** Convert from a non-empty sequence of digits (which may contain "_") *) + + val to_string : t -> string + (** Convert to a non-empty sequence of digit that does not contain "_" *) + + val sprint : t -> string + val print : t -> Pp.t + (** [sprint] and [print] returns the numeral as it was parsed, for printing *) + + val compare : t -> t -> int +end + +(** {6 String representation of a signed natural number } *) + +module SignedNat : +sig + type t = sign * UnsignedNat.t + val of_string : string -> t + (** Convert from a non-empty sequence of digits which may contain "_" *) + + val to_string : t -> string + (** Convert to a non-empty sequence of digit that does not contain "_" *) + + val to_bigint : t -> Bigint.bigint + val of_bigint : Bigint.bigint -> t +end + +(** {6 Unsigned decimal numerals } *) + +module Unsigned : +sig + type t + val equal : t -> t -> bool + val is_nat : t -> bool + val to_nat : t -> string option + + val sprint : t -> string + val print : t -> Pp.t + (** [sprint] and [print] returns the numeral as it was parsed, for printing *) + + val parse : char Stream.t -> t + (** Parse a positive Coq numeral. + Precondition: the first char on the stream is already known to be a digit (\[0-9\]). + Precondition: at least two extra chars after the numeral to parse. + + The recognized syntax is: + - integer part: \[0-9\]\[0-9_\]* + - decimal part: empty or .\[0-9_\]+ + - exponent part: empty or \[eE\]\[+-\]?\[0-9\]\[0-9_\]* *) + + val parse_string : string -> t option + (** Parse the string as a positive Coq numeral, if possible *) + +end + +(** {6 Signed decimal numerals } *) + +module Signed : +sig + type t = sign * Unsigned.t + val equal : t -> t -> bool + val is_zero : t -> bool + val of_nat : UnsignedNat.t -> t + val of_int : SignedNat.t -> t + val to_int : t -> SignedNat.t option + val is_int : t -> bool + + val sprint : t -> string + val print : t -> Pp.t + (** [sprint] and [print] returns the numeral as it was parsed, for printing *) + + val parse_string : string -> t option + (** Parse the string as a signed Coq numeral, if possible *) + + val of_int_string : string -> t + (** Convert from a string in the syntax of OCaml's int/int64 *) + + val of_string : string -> t + (** Convert from a string in the syntax of OCaml's string_of_float *) + + val to_string : t -> string + (** Returns a string in the syntax of OCaml's float_of_string *) + + val of_bigint : Bigint.bigint -> t + val to_bigint : t -> Bigint.bigint option + (** Convert from and to bigint when the denotation of a bigint *) + + val of_decimal_and_exponent : SignedNat.t -> UnsignedNat.t option -> SignedNat.t option -> t + val to_decimal_and_exponent : t -> SignedNat.t * UnsignedNat.t option * SignedNat.t option + (** n, p and q such that the number is n.p*10^q *) + + val to_bigint_and_exponent : t -> Bigint.bigint * Bigint.bigint + val of_bigint_and_exponent : Bigint.bigint -> Bigint.bigint -> t + (** n and p such that the number is n*10^p *) + + val is_bigger_int_than : t -> UnsignedNat.t -> bool + (** Test if an integer whose absolute value is bounded *) + +end diff --git a/kernel/byterun/coq_gc.h b/kernel/byterun/coq_gc.h deleted file mode 100644 index 38eda4d11f..0000000000 --- a/kernel/byterun/coq_gc.h +++ /dev/null @@ -1,59 +0,0 @@ -/***********************************************************************/ -/* */ -/* Coq Compiler */ -/* */ -/* Benjamin Gregoire, projets Logical and Cristal */ -/* INRIA Rocquencourt */ -/* */ -/* */ -/***********************************************************************/ - -#ifndef _COQ_CAML_GC_ -#define _COQ_CAML_GC_ -#include <caml/mlvalues.h> -#include <caml/alloc.h> -#include <caml/memory.h> - -typedef void (*scanning_action) (value, value *); - - -CAMLextern char *young_ptr; -CAMLextern char *young_limit; -CAMLextern void (*scan_roots_hook) (scanning_action); -CAMLextern void minor_collection (void); - -#define Caml_white (0 << 8) -#define Caml_black (3 << 8) - -#ifdef HAS_OCP_MEMPROF - -/* This code is necessary to make the OCamlPro memory profiling branch of - OCaml compile. */ - -#define Make_header(wosize, tag, color) \ - caml_make_header(wosize, tag, color) - -#else - -#define Make_header(wosize, tag, color) \ - (((header_t) (((header_t) (wosize) << 10) \ - + (color) \ - + (tag_t) (tag))) \ - ) -#endif - -#define Alloc_small(result, wosize, tag) do{ \ - young_ptr -= Bhsize_wosize (wosize); \ - if (young_ptr < young_limit){ \ - young_ptr += Bhsize_wosize (wosize); \ - Setup_for_gc; \ - minor_collection (); \ - Restore_after_gc; \ - young_ptr -= Bhsize_wosize (wosize); \ - } \ - Hd_hp (young_ptr) = Make_header ((wosize), (tag), Caml_black); \ - (result) = Val_hp (young_ptr); \ - }while(0) - - -#endif /*_COQ_CAML_GC_ */ diff --git a/kernel/byterun/coq_interp.c b/kernel/byterun/coq_interp.c index 606cce0127..7588c1ce07 100644 --- a/kernel/byterun/coq_interp.c +++ b/kernel/byterun/coq_interp.c @@ -16,17 +16,37 @@ #include <stdio.h> #include <signal.h> #include <stdint.h> +#include <math.h> + +#define CAML_INTERNALS #include <caml/memory.h> #include <caml/signals.h> #include <caml/version.h> -#include <math.h> -#include "coq_gc.h" + #include "coq_instruct.h" #include "coq_fix_code.h" #include "coq_memory.h" #include "coq_values.h" #include "coq_float64.h" +#if OCAML_VERSION < 41000 +extern void caml_minor_collection(void); + +#undef Alloc_small +#define Alloc_small(result, wosize, tag) do{ \ + caml_young_ptr -= Bhsize_wosize(wosize); \ + if (caml_young_ptr < caml_young_limit) { \ + caml_young_ptr += Bhsize_wosize(wosize); \ + Setup_for_gc; \ + caml_minor_collection(); \ + Restore_after_gc; \ + caml_young_ptr -= Bhsize_wosize(wosize); \ + } \ + Hd_hp(caml_young_ptr) = Make_header((wosize), (tag), Caml_black); \ + (result) = Val_hp(caml_young_ptr); \ + }while(0) +#endif + #ifdef ARCH_SIXTYFOUR #include "coq_uint63_native.h" #else diff --git a/kernel/byterun/coq_memory.c b/kernel/byterun/coq_memory.c index 91d6773b1f..6233675c66 100644 --- a/kernel/byterun/coq_memory.c +++ b/kernel/byterun/coq_memory.c @@ -10,9 +10,12 @@ #include <stdio.h> #include <string.h> + +#define CAML_INTERNALS #include <caml/alloc.h> #include <caml/address_class.h> -#include "coq_gc.h" +#include <caml/roots.h> + #include "coq_instruct.h" #include "coq_fix_code.h" #include "coq_memory.h" diff --git a/kernel/float64.ml b/kernel/float64.ml index 299f53e8ab..53fc13b04b 100644 --- a/kernel/float64.ml +++ b/kernel/float64.ml @@ -21,12 +21,19 @@ let is_neg_infinity f = f = neg_infinity (* Printing a binary64 float in 17 decimal places and parsing it again will yield the same float. We assume [to_string_raw] is not given a - [nan] as input. *) + [nan] or an infinity as input. *) let to_string_raw f = Printf.sprintf "%.17g" f (* OCaml gives a sign to nan values which should not be displayed as - all NaNs are considered equal here *) -let to_string f = if is_nan f then "nan" else to_string_raw f + all NaNs are considered equal here. + OCaml prints infinities as "inf" (resp. "-inf") + but we want "infinity" (resp. "neg_infinity"). *) +let to_string f = + if is_nan f then "nan" + else if is_infinity f then "infinity" + else if is_neg_infinity f then "neg_infinity" + else to_string_raw f + let of_string = float_of_string (* Compiles a float to OCaml code *) diff --git a/kernel/kernel.mllib b/kernel/kernel.mllib index f1e994b337..cc9da3a2ce 100644 --- a/kernel/kernel.mllib +++ b/kernel/kernel.mllib @@ -27,7 +27,7 @@ Conv_oracle Environ Primred CClosure -Retypeops +Relevanceops Reduction Clambda Nativelambda diff --git a/kernel/modops.ml b/kernel/modops.ml index 5dd5499a26..301af328e4 100644 --- a/kernel/modops.ml +++ b/kernel/modops.ml @@ -382,21 +382,21 @@ let inline_delta_resolver env inl mp mbid mtb delta = let rec make_inline delta = function | [] -> delta | (lev,kn)::r -> - let kn = replace_mp_in_kn (MPbound mbid) mp kn in - let con = constant_of_delta_kn delta kn in - try - let constant = lookup_constant con env in - let l = make_inline delta r in - match constant.const_body with - | Undef _ | OpaqueDef _ | Primitive _ -> l - | Def body -> - let constr = Mod_subst.force_constr body in - let ctx = Declareops.constant_polymorphic_context constant in - let constr = Univ.{univ_abstracted_value=constr; univ_abstracted_binder=ctx} in - add_inline_delta_resolver kn (lev, Some constr) l - with Not_found -> - error_no_such_label_sub (Constant.label con) - (ModPath.to_string (Constant.modpath con)) + let kn = replace_mp_in_kn (MPbound mbid) mp kn in + let con = constant_of_delta_kn delta kn in + if not (Environ.mem_constant con env) then + error_no_such_label_sub (Constant.label con) + (ModPath.to_string (Constant.modpath con)) + else + let constant = lookup_constant con env in + let l = make_inline delta r in + match constant.const_body with + | Undef _ | OpaqueDef _ | Primitive _ -> l + | Def body -> + let constr = Mod_subst.force_constr body in + let ctx = Declareops.constant_polymorphic_context constant in + let constr = Univ.{univ_abstracted_value=constr; univ_abstracted_binder=ctx} in + add_inline_delta_resolver kn (lev, Some constr) l in make_inline delta constants diff --git a/kernel/reduction.ml b/kernel/reduction.ml index 66c4067506..7574d7b21e 100644 --- a/kernel/reduction.ml +++ b/kernel/reduction.ml @@ -331,7 +331,7 @@ let skip_pattern infos n c1 c2 = let is_irrelevant infos lft c = let env = info_env infos.cnv_inf in - try Retypeops.relevance_of_fterm env infos.relevances lft c == Sorts.Irrelevant with _ -> false + try Relevanceops.relevance_of_fterm env infos.relevances lft c == Sorts.Irrelevant with _ -> false (* Conversion between [lft1]term1 and [lft2]term2 *) let rec ccnv cv_pb l2r infos lft1 lft2 term1 term2 cuniv = diff --git a/kernel/retypeops.ml b/kernel/relevanceops.ml index 3f3e722245..3f3e722245 100644 --- a/kernel/retypeops.ml +++ b/kernel/relevanceops.ml diff --git a/kernel/retypeops.mli b/kernel/relevanceops.mli index 86734e747e..86734e747e 100644 --- a/kernel/retypeops.mli +++ b/kernel/relevanceops.mli diff --git a/kernel/term_typing.ml b/kernel/term_typing.ml index 0c89d51033..c8c2301171 100644 --- a/kernel/term_typing.ml +++ b/kernel/term_typing.ml @@ -143,7 +143,7 @@ let infer_declaration env (dcl : constant_entry) = Cooking.cook_body = def; cook_type = typ; cook_universes = univs; - cook_relevance = Retypeops.relevance_of_term env j.uj_val; + cook_relevance = Relevanceops.relevance_of_term env j.uj_val; cook_inline = c.const_entry_inline_code; cook_context = c.const_entry_secctx; } diff --git a/kernel/vars.ml b/kernel/vars.ml index 4c66f1574f..a4465c293b 100644 --- a/kernel/vars.ml +++ b/kernel/vars.ml @@ -169,9 +169,6 @@ let subst_of_rel_context_instance sign l = | _ -> CErrors.anomaly (Pp.str "Instance and signature do not match.") in aux [] (List.rev sign) l -let adjust_subst_to_rel_context sign l = - List.rev (subst_of_rel_context_instance sign l) - let adjust_rel_to_rel_context sign n = let rec aux sign = let open RelDecl in diff --git a/kernel/vars.mli b/kernel/vars.mli index 52a6159f0a..0aac5ed4ce 100644 --- a/kernel/vars.mli +++ b/kernel/vars.mli @@ -72,9 +72,6 @@ type substl = constr list [c₁], as if usable for [substl]. *) val subst_of_rel_context_instance : Constr.rel_context -> constr list -> substl -(** For compatibility: returns the substitution reversed *) -val adjust_subst_to_rel_context : Constr.rel_context -> constr list -> constr list - (** Take an index in an instance of a context and returns its index wrt to the full context (e.g. 2 in [x:A;y:=b;z:C] is 3, i.e. a reference to z) *) val adjust_rel_to_rel_context : ('a, 'b) Context.Rel.pt -> int -> int diff --git a/lib/system.ml b/lib/system.ml index 68410e322a..d7f5fa26ab 100644 --- a/lib/system.ml +++ b/lib/system.ml @@ -11,7 +11,6 @@ (* $Id$ *) open Pp -open Util include Minisys @@ -42,15 +41,7 @@ let all_subdirs ~unix_path:root = (* Caching directory contents for efficient syntactic equality of file names even on case-preserving but case-insensitive file systems *) -module StrMod = struct - type t = string - let compare = compare -end - -module StrMap = Map.Make(StrMod) -module StrSet = Set.Make(StrMod) - -let dirmap = ref StrMap.empty +let dirmap = ref CString.Map.empty let make_dir_table dir = let entries = @@ -59,8 +50,8 @@ let make_dir_table dir = with Sys_error _ -> warn_cannot_open_dir dir; [||] in - let filter_dotfiles s f = if f.[0] = '.' then s else StrSet.add f s in - Array.fold_left filter_dotfiles StrSet.empty entries + let filter_dotfiles s f = if f.[0] = '.' then s else CString.Set.add f s in + Array.fold_left filter_dotfiles CString.Set.empty entries (** Don't trust in interactive mode (the default) *) let trust_file_cache = ref false @@ -68,20 +59,20 @@ let trust_file_cache = ref false let exists_in_dir_respecting_case dir bf = let cache_dir dir = let contents = make_dir_table dir in - dirmap := StrMap.add dir contents !dirmap; + dirmap := CString.Map.add dir contents !dirmap; contents in let contents, fresh = try (* in batch mode, assume the directory content is still fresh *) - StrMap.find dir !dirmap, !trust_file_cache + CString.Map.find dir !dirmap, !trust_file_cache with Not_found -> (* in batch mode, we are not yet sure the directory exists *) - if !trust_file_cache && not (exists_dir dir) then StrSet.empty, true + if !trust_file_cache && not (exists_dir dir) then CString.Set.empty, true else cache_dir dir, true in - StrSet.mem bf contents || + CString.Set.mem bf contents || not fresh && (* rescan, there is a new file we don't know about *) - StrSet.mem bf (cache_dir dir) + CString.Set.mem bf (cache_dir dir) let file_exists_respecting_case path f = (* This function ensures that a file with expected lowercase/uppercase diff --git a/library/libnames.ml b/library/libnames.ml index 6f55a8dc3d..88b2e41855 100644 --- a/library/libnames.ml +++ b/library/libnames.ml @@ -78,9 +78,6 @@ let dirpath_of_string s = in DirPath.make path -module Dirset = Set.Make(DirPath) -module Dirmap = Map.Make(DirPath) - (*s Section paths are absolute names *) type full_path = { diff --git a/library/libnames.mli b/library/libnames.mli index 23792e54c2..a384510879 100644 --- a/library/libnames.mli +++ b/library/libnames.mli @@ -8,7 +8,6 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -open Util open Names (** {6 Dirpaths } *) @@ -34,9 +33,6 @@ val is_dirpath_prefix_of : DirPath.t -> DirPath.t -> bool val is_dirpath_suffix_of : DirPath.t -> DirPath.t -> bool -module Dirset : Set.S with type elt = DirPath.t -module Dirmap : Map.ExtS with type key = DirPath.t and module Set := Dirset - (** {6 Full paths are {e absolute} paths of declarations } *) type full_path diff --git a/parsing/cLexer.ml b/parsing/cLexer.ml index 6a436fbcb7..85640cabba 100644 --- a/parsing/cLexer.ml +++ b/parsing/cLexer.ml @@ -392,22 +392,6 @@ let comments = ref [] let current_comment = Buffer.create 8192 let between_commands = ref true -(* The state of the lexer visible from outside *) -type lexer_state = int option * string * bool * ((int * int) * string) list - -let init_lexer_state () = (None,"",true,[]) -let set_lexer_state (o,s,b,c) = - comment_begin := o; - Buffer.clear current_comment; Buffer.add_string current_comment s; - between_commands := b; - comments := c -let get_lexer_state () = - (!comment_begin, Buffer.contents current_comment, !between_commands, !comments) -let drop_lexer_state () = - set_lexer_state (init_lexer_state ()) - -let get_comment_state (_,_,_,c) = c - let real_push_char c = Buffer.add_char current_comment c (* Add a char if it is between two commands, if it is a newline or @@ -723,7 +707,7 @@ let rec next_token ~diff_mode loc s = let ep = Stream.count s in IDENT id, set_loc_pos loc bp ep end | Some ('0'..'9') -> - let n = NumTok.parse s in + let n = NumTok.Unsigned.parse s in let ep = Stream.count s in comment_stop bp; (NUMERAL n, set_loc_pos loc bp ep) @@ -813,7 +797,7 @@ let token_text : type c. c Tok.p -> string = function | PIDENT None -> "identifier" | PIDENT (Some t) -> "'" ^ t ^ "'" | PNUMERAL None -> "numeral" - | PNUMERAL (Some n) -> "'" ^ NumTok.to_string n ^ "'" + | PNUMERAL (Some n) -> "'" ^ NumTok.Unsigned.sprint n ^ "'" | PSTRING None -> "string" | PSTRING (Some s) -> "STRING \"" ^ s ^ "\"" | PLEFTQMARK -> "LEFTQMARK" @@ -851,6 +835,24 @@ module MakeLexer (Diff : sig val mode : bool end) = struct let tok_removing = (fun _ -> ()) let tok_match = Tok.match_pattern let tok_text = token_text + + (* The state of the lexer visible from outside *) + module State = struct + + type t = int option * string * bool * ((int * int) * string) list + + let init () = (None,"",true,[]) + let set (o,s,b,c) = + comment_begin := o; + Buffer.clear current_comment; Buffer.add_string current_comment s; + between_commands := b; + comments := c + let get () = + (!comment_begin, Buffer.contents current_comment, !between_commands, !comments) + let drop () = set (init ()) + let get_comments (_,_,_,c) = c + + end end module Lexer = MakeLexer (struct let mode = false end) @@ -888,6 +890,6 @@ let terminal s = else PKEYWORD s (* Precondition: the input is a numeral (c.f. [NumTok.t]) *) -let terminal_numeral s = match NumTok.of_string s with +let terminal_numeral s = match NumTok.Unsigned.parse_string s with | Some n -> PNUMERAL (Some n) | None -> failwith "numeral token expected." diff --git a/parsing/cLexer.mli b/parsing/cLexer.mli index 3ce6981879..ac2c5bcfe2 100644 --- a/parsing/cLexer.mli +++ b/parsing/cLexer.mli @@ -50,12 +50,12 @@ val check_keyword : string -> unit val terminal : string -> string Tok.p (** Precondition: the input is a numeral (c.f. [NumTok.t]) *) -val terminal_numeral : string -> NumTok.t Tok.p +val terminal_numeral : string -> NumTok.Unsigned.t Tok.p (** The lexer of Coq: *) module Lexer : - Gramlib.Grammar.GLexerType with type te = Tok.t and type 'c pattern = 'c Tok.p + Gramlib.Plexing.S with type te = Tok.t and type 'c pattern = 'c Tok.p module Error : sig type t @@ -63,15 +63,6 @@ module Error : sig val to_string : t -> string end -(* Mainly for comments state, etc... *) -type lexer_state - -val init_lexer_state : unit -> lexer_state -val set_lexer_state : lexer_state -> unit -val get_lexer_state : unit -> lexer_state -val drop_lexer_state : unit -> unit -val get_comment_state : lexer_state -> ((int * int) * string) list - (** Create a lexer. true enables alternate handling for computing diffs. It ensures that, ignoring white space, the concatenated tokens equal the input string. Specifically: @@ -81,5 +72,6 @@ as if it was unquoted, possibly becoming multiple tokens it was not in a comment, possibly becoming multiple tokens - return any unrecognized Ascii or UTF-8 character as a string *) + module LexerDiff : - Gramlib.Grammar.GLexerType with type te = Tok.t and type 'c pattern = 'c Tok.p + Gramlib.Plexing.S with type te = Tok.t and type 'c pattern = 'c Tok.p diff --git a/parsing/extend.ml b/parsing/extend.ml index 20297fa156..fadfb6c5f4 100644 --- a/parsing/extend.ml +++ b/parsing/extend.ml @@ -10,8 +10,6 @@ (** Entry keys for constr notations *) -type 'a entry = 'a Gramlib.Grammar.GMake(CLexer.Lexer).Entry.t - type side = Left | Right type production_position = @@ -77,36 +75,3 @@ type ('a,'b,'c) ty_user_symbol = | TUopt : ('a,'b,'c) ty_user_symbol -> ('a option, 'b option, 'c option) ty_user_symbol | TUentry : ('a, 'b, 'c) Genarg.ArgT.tag -> ('a,'b,'c) ty_user_symbol | TUentryl : ('a, 'b, 'c) Genarg.ArgT.tag * int -> ('a,'b,'c) ty_user_symbol - -(** {5 Type-safe grammar extension} *) - -(* Should be merged with gramlib's implementation *) - -type norec = Gramlib.Grammar.norec -type mayrec = Gramlib.Grammar.mayrec - -type ('self, 'trec, 'a) symbol = -| Atoken : 'c Tok.p -> ('self, norec, 'c) symbol -| Alist1 : ('self, 'trec, 'a) symbol -> ('self, 'trec, 'a list) symbol -| Alist1sep : ('self, 'trec, 'a) symbol * ('self, norec, _) symbol - -> ('self, 'trec, 'a list) symbol -| Alist0 : ('self, 'trec, 'a) symbol -> ('self, 'trec, 'a list) symbol -| Alist0sep : ('self, 'trec, 'a) symbol * ('self, norec, _) symbol - -> ('self, 'trec, 'a list) symbol -| Aopt : ('self, 'trec, 'a) symbol -> ('self, 'trec, 'a option) symbol -| Aself : ('self, mayrec, 'self) symbol -| Anext : ('self, mayrec, 'self) symbol -| Aentry : 'a entry -> ('self, norec, 'a) symbol -| Aentryl : 'a entry * string -> ('self, norec, 'a) symbol -| Arules : 'a rules list -> ('self, norec, 'a) symbol - -and ('self, 'trec, _, 'r) rule = -| Stop : ('self, norec, 'r, 'r) rule -| Next : ('self, _, 'a, 'r) rule * ('self, _, 'b) symbol -> ('self, mayrec, 'b -> 'a, 'r) rule -| NextNoRec : ('self, norec, 'a, 'r) rule * ('self, norec, 'b) symbol -> ('self, norec, 'b -> 'a, 'r) rule - -and 'a rules = -| Rules : (_, norec, 'act, Loc.t -> 'a) rule * 'act -> 'a rules - -type 'a production_rule = -| Rule : ('a, _, 'act, Loc.t -> 'a) rule * 'act -> 'a production_rule diff --git a/parsing/g_constr.mlg b/parsing/g_constr.mlg index 3fd756e748..963f029766 100644 --- a/parsing/g_constr.mlg +++ b/parsing/g_constr.mlg @@ -174,7 +174,7 @@ GRAMMAR EXTEND Gram { (* Preserve parentheses around numerals so that constrintern does not collapse -(3) into the numeral -3. *) (match c.CAst.v with - | CPrim (Numeral (SPlus,n)) -> + | CPrim (Numeral (NumTok.SPlus,n)) -> CAst.make ~loc @@ CNotation(None,(InConstrEntrySomeLevel,"( _ )"),([c],[],[],[])) | _ -> c) } | "{|"; c = record_declaration; bar_cbrace -> { c } @@ -248,7 +248,7 @@ GRAMMAR EXTEND Gram atomic_constr: [ [ g = global; i = univ_instance -> { CAst.make ~loc @@ CRef (g,i) } | s = sort -> { CAst.make ~loc @@ CSort s } - | n = NUMERAL-> { CAst.make ~loc @@ CPrim (Numeral (SPlus,n)) } + | n = NUMERAL-> { CAst.make ~loc @@ CPrim (Numeral (NumTok.SPlus,n)) } | s = string -> { CAst.make ~loc @@ CPrim (String s) } | "_" -> { CAst.make ~loc @@ CHole (None, IntroAnonymous, None) } | "?"; "["; id = ident; "]" -> { CAst.make ~loc @@ CHole (None, IntroIdentifier id, None) } @@ -355,12 +355,12 @@ GRAMMAR EXTEND Gram { (* Preserve parentheses around numerals so that constrintern does not collapse -(3) into the numeral -3. *) match p.CAst.v with - | CPatPrim (Numeral (SPlus,n)) -> + | CPatPrim (Numeral (NumTok.SPlus,n)) -> CAst.make ~loc @@ CPatNotation(None,(InConstrEntrySomeLevel,"( _ )"),([p],[]),[]) | _ -> p } | "("; p = pattern LEVEL "200"; "|" ; pl = LIST1 pattern LEVEL "200" SEP "|"; ")" -> { CAst.make ~loc @@ CPatOr (p::pl) } - | n = NUMERAL-> { CAst.make ~loc @@ CPatPrim (Numeral (SPlus,n)) } + | n = NUMERAL-> { CAst.make ~loc @@ CPatPrim (Numeral (NumTok.SPlus,n)) } | s = string -> { CAst.make ~loc @@ CPatPrim (String s) } ] ] ; fixannot: diff --git a/parsing/g_prim.mlg b/parsing/g_prim.mlg index e8e802f606..9c50109bb3 100644 --- a/parsing/g_prim.mlg +++ b/parsing/g_prim.mlg @@ -21,15 +21,18 @@ let _ = List.iter CLexer.add_keyword prim_kw let local_make_qualid loc l id = make_qualid ~loc (DirPath.make l) id -let check_int loc = function - | { NumTok.int = i; frac = ""; exp = "" } -> i - | _ -> CErrors.user_err ~loc (Pp.str "This number is not an integer.") - -let my_int_of_string loc s = +let my_int_of_string ?loc s = try int_of_string s with Failure _ -> - CErrors.user_err ~loc (Pp.str "This number is too large.") + CErrors.user_err ?loc (Pp.str "This number is too large.") + +let my_to_nat_string ?loc ispos s = + match NumTok.Unsigned.to_nat s with + | Some n -> n + | None -> + let pos = if ispos then "a natural" else "an integer" in + CErrors.user_err ?loc Pp.(str "This number is not " ++ str pos ++ str " number.") let test_pipe_closedcurly = let open Pcoq.Lookahead in @@ -47,7 +50,7 @@ let test_minus_nat = GRAMMAR EXTEND Gram GLOBAL: - bigint natural integer identref name ident var preident + bignat bigint natural integer identref name ident var preident fullyqualid qualid reference dirpath ne_lstring ne_string string lstring pattern_ident pattern_identref by_notation smart_global bar_cbrace; @@ -122,15 +125,18 @@ GRAMMAR EXTEND Gram [ [ s = string -> { CAst.make ~loc s } ] ] ; integer: - [ [ i = NUMERAL -> { my_int_of_string loc (check_int loc i) } - | test_minus_nat; "-"; i = NUMERAL -> { - my_int_of_string loc (check_int loc i) } ] ] + [ [ i = bigint -> { my_int_of_string ~loc i } ] ] ; natural: - [ [ i = NUMERAL -> { my_int_of_string loc (check_int loc i) } ] ] + [ [ i = bignat -> { my_int_of_string ~loc i } ] ] ; - bigint: (* Negative numbers are dealt with elsewhere *) - [ [ i = NUMERAL -> { check_int loc i } ] ] + bigint: + [ [ i = NUMERAL -> { my_to_nat_string true ~loc i } + | test_minus_nat; "-"; i = NUMERAL -> { "-" ^ my_to_nat_string ~loc false i } ] ] ; + bignat: + [ [ i = NUMERAL -> { my_to_nat_string ~loc true i } ] ] + ; bar_cbrace: [ [ test_pipe_closedcurly; "|"; "}" -> { () } ] ] ; diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml index fe2412fcd7..5b0562fb0d 100644 --- a/parsing/pcoq.ml +++ b/parsing/pcoq.ml @@ -10,113 +10,11 @@ open CErrors open Util -open Extend open Genarg open Gramlib (** The parser of Coq *) -module G : sig - - include Grammar.S with type te = Tok.t and type 'c pattern = 'c Tok.p - -(* where Grammar.S - -module type S = - sig - type te = 'x; - type parsable = 'x; - value parsable : Stream.t char -> parsable; - value tokens : string -> list (string * int); - value glexer : Plexing.lexer te; - value set_algorithm : parse_algorithm -> unit; - module Entry : - sig - type e 'a = 'y; - value create : string -> e 'a; - value parse : e 'a -> parsable -> 'a; - value parse_token_stream : e 'a -> Stream.t te -> 'a; - value name : e 'a -> string; - value of_parser : string -> (Stream.t te -> 'a) -> e 'a; - value print : Format.formatter -> e 'a -> unit; - external obj : e 'a -> Gramext.g_entry te = "%identity"; - end - ; - module Unsafe : - sig - value gram_reinit : Plexing.lexer te -> unit; - value clear_entry : Entry.e 'a -> unit; - end - ; - value extend : - Entry.e 'a -> option Gramext.position -> - list - (option string * option Gramext.g_assoc * - list (list (Gramext.g_symbol te) * Gramext.g_action)) -> - unit; - value delete_rule : Entry.e 'a -> list (Gramext.g_symbol te) -> unit; - end - *) - - type coq_parsable - - val coq_parsable : ?loc:Loc.t -> char Stream.t -> coq_parsable - val entry_create : string -> 'a entry - val entry_parse : 'a entry -> coq_parsable -> 'a - - val comment_state : coq_parsable -> ((int * int) * string) list - -end with type 'a Entry.t = 'a Extend.entry = struct - - include Grammar.GMake(CLexer.Lexer) - - type coq_parsable = Parsable.t * CLexer.lexer_state ref - - let coq_parsable ?loc c = - let state = ref (CLexer.init_lexer_state ()) in - CLexer.set_lexer_state !state; - let a = Parsable.make ?loc c in - state := CLexer.get_lexer_state (); - (a,state) - - let entry_create = Entry.make - - let entry_parse e (p,state) = - CLexer.set_lexer_state !state; - try - let c = Entry.parse e p in - state := CLexer.get_lexer_state (); - c - with Ploc.Exc (loc,e) -> - CLexer.drop_lexer_state (); - let loc' = Loc.get_loc (Exninfo.info e) in - let loc = match loc' with None -> loc | Some loc -> loc in - Loc.raise ~loc e - - let comment_state (p,state) = - CLexer.get_comment_state !state - -end - -module Parsable = -struct - type t = G.coq_parsable - let make = G.coq_parsable - let comment_state = G.comment_state -end - -module Entry = -struct - - type 'a t = 'a Grammar.GMake(CLexer.Lexer).Entry.t - - let create = G.Entry.make - let parse = G.entry_parse - let print = G.Entry.print - let of_parser = G.Entry.of_parser - let name = G.Entry.name - let parse_token_stream = G.Entry.parse_token_stream - -end +include Grammar.GMake(CLexer.Lexer) module Lookahead = struct @@ -166,7 +64,7 @@ struct | _ -> None let lk_nat tok n strm = match stream_nth n strm with - | Tok.NUMERAL { NumTok.int = _; frac = ""; exp = "" } -> Some (n + 1) + | Tok.NUMERAL p when NumTok.Unsigned.is_nat p -> Some (n + 1) | _ -> None let rec lk_list lk_elem n strm = @@ -187,100 +85,21 @@ end In [single_extend_statement], first two parameters are name and assoc iff a level is created *) -(** Binding general entry keys to symbol *) - -let rec symbol_of_prod_entry_key : type s tr a. (s, tr, a) symbol -> (s, tr, a) G.Symbol.t = -function -| Atoken t -> G.Symbol.token t -| Alist1 s -> - let s = symbol_of_prod_entry_key s in - G.Symbol.list1 s -| Alist1sep (s,sep) -> - let s = symbol_of_prod_entry_key s in - let sep = symbol_of_prod_entry_key sep in - G.Symbol.list1sep s sep false -| Alist0 s -> - let s = symbol_of_prod_entry_key s in - G.Symbol.list0 s -| Alist0sep (s,sep) -> - let s = symbol_of_prod_entry_key s in - let sep = symbol_of_prod_entry_key sep in - G.Symbol.list0sep s sep false -| Aopt s -> - let s = symbol_of_prod_entry_key s in - G.Symbol.opt s -| Aself -> G.Symbol.self -| Anext -> G.Symbol.next -| Aentry e -> G.Symbol.nterm e -| Aentryl (e, n) -> G.Symbol.nterml e n -| Arules rs -> - let warning msg = Feedback.msg_warning Pp.(str msg) in - G.Symbol.rules ~warning:(Some warning) (List.map symbol_of_rules rs) - -and symbol_of_rule : type s tr a r. (s, tr, a, Loc.t -> r) Extend.rule -> (s, tr, a, Loc.t -> r) G.Rule.t = function -| Stop -> - G.Rule.stop -| Next (r, s) -> - let r = symbol_of_rule r in - let s = symbol_of_prod_entry_key s in - G.Rule.next r s -| NextNoRec (r, s) -> - let r = symbol_of_rule r in - let s = symbol_of_prod_entry_key s in - G.Rule.next_norec r s - -and symbol_of_rules : type a. a Extend.rules -> a G.Rules.t = function -| Rules (r, act) -> - let symb = symbol_of_rule r in - G.Rules.make symb act - -(** FIXME: This is a hack around a deficient camlp5 API *) -type 'a any_production = AnyProduction : ('a, 'tr, 'f, Loc.t -> 'a) G.Rule.t * 'f -> 'a any_production - -let of_coq_production_rule : type a. a Extend.production_rule -> a any_production = function -| Rule (toks, act) -> - AnyProduction (symbol_of_rule toks, act) - -let of_coq_single_extend_statement (lvl, assoc, rule) = - (lvl, assoc, List.map of_coq_production_rule rule) - -let of_coq_extend_statement (pos, st) = - (pos, List.map of_coq_single_extend_statement st) - -let fix_extend_statement (pos, st) = - let fix_single_extend_statement (lvl, assoc, rules) = - let fix_production_rule (AnyProduction (s, act)) = G.Production.make s act in - (lvl, assoc, List.map fix_production_rule rules) - in - (pos, List.map fix_single_extend_statement st) - (** Type of reinitialization data *) type gram_reinit = Gramlib.Gramext.g_assoc * Gramlib.Gramext.position -type 'a single_extend_statement = - string option * - (* Level *) - Gramlib.Gramext.g_assoc option * - (* Associativity *) - 'a production_rule list - (* Symbol list with the interpretation function *) - -type 'a extend_statement = - Gramlib.Gramext.position option * - 'a single_extend_statement list - type extend_rule = | ExtendRule : 'a Entry.t * 'a extend_statement -> extend_rule | ExtendRuleReinit : 'a Entry.t * gram_reinit * 'a extend_statement -> extend_rule module EntryCommand = Dyn.Make () -module EntryData = struct type _ t = Ex : 'b G.Entry.t String.Map.t -> ('a * 'b) t end +module EntryData = struct type _ t = Ex : 'b Entry.t String.Map.t -> ('a * 'b) t end module EntryDataMap = EntryCommand.Map(EntryData) type ext_kind = | ByGrammar of extend_rule | ByEXTEND of (unit -> unit) * (unit -> unit) - | ByEntry : ('a * 'b) EntryCommand.tag * string * 'b G.Entry.t -> ext_kind + | ByEntry : ('a * 'b) EntryCommand.tag * string * 'b Entry.t -> ext_kind (** The list of extensions *) @@ -290,49 +109,37 @@ let camlp5_entries = ref EntryDataMap.empty (** Deletion *) -let grammar_delete e (pos,rls) = +let grammar_delete e { pos; data } = List.iter (fun (n,ass,lev) -> - List.iter (fun (AnyProduction (pil,_)) -> G.safe_delete_rule e pil) (List.rev lev)) - (List.rev rls) + List.iter (fun pil -> safe_delete_rule e pil) (List.rev lev)) + (List.rev data) -let grammar_delete_reinit e reinit (pos, rls) = - grammar_delete e (pos, rls); +let grammar_delete_reinit e reinit ({ pos; data } as d)= + grammar_delete e d; let a, ext = reinit in let lev = match pos with | Some (Gramext.Level n) -> n | _ -> assert false in - let warning msg = Feedback.msg_warning Pp.(str msg) in - (G.safe_extend ~warning:(Some warning) e) (Some ext) [Some lev,Some a,[]] + let ext = { pos = Some ext; data = [Some lev,Some a,[]] } in + safe_extend e ext (** Extension *) let grammar_extend e ext = - let ext = of_coq_extend_statement ext in let undo () = grammar_delete e ext in - let pos, ext = fix_extend_statement ext in - let redo () = G.safe_extend ~warning:None e pos ext in + let redo () = safe_extend e ext in camlp5_state := ByEXTEND (undo, redo) :: !camlp5_state; redo () let grammar_extend_sync e ext = camlp5_state := ByGrammar (ExtendRule (e, ext)) :: !camlp5_state; - let pos, ext = fix_extend_statement (of_coq_extend_statement ext) in - G.safe_extend ~warning:None e pos ext + safe_extend e ext let grammar_extend_sync_reinit e reinit ext = camlp5_state := ByGrammar (ExtendRuleReinit (e, reinit, ext)) :: !camlp5_state; - let pos, ext = fix_extend_statement (of_coq_extend_statement ext) in - G.safe_extend ~warning:None e pos ext - -(** The apparent parser of Coq; encapsulate G to keep track - of the extensions. *) - -module Gram = - struct - include G - end + safe_extend e ext (** Remove extensions @@ -344,11 +151,11 @@ let rec remove_grammars n = match !camlp5_state with | [] -> anomaly ~label:"Pcoq.remove_grammars" (Pp.str "too many rules to remove.") | ByGrammar (ExtendRuleReinit (g, reinit, ext)) :: t -> - grammar_delete_reinit g reinit (of_coq_extend_statement ext); + grammar_delete_reinit g reinit ext; camlp5_state := t; remove_grammars (n-1) | ByGrammar (ExtendRule (g, ext)) :: t -> - grammar_delete g (of_coq_extend_statement ext); + grammar_delete g ext; camlp5_state := t; remove_grammars (n-1) | ByEXTEND (undo,redo)::t -> @@ -358,7 +165,7 @@ let rec remove_grammars n = redo(); camlp5_state := ByEXTEND (undo,redo) :: !camlp5_state | ByEntry (tag, name, e) :: t -> - G.Unsafe.clear_entry e; + Unsafe.clear_entry e; camlp5_state := t; let EntryData.Ex entries = try EntryDataMap.find tag !camlp5_entries @@ -373,19 +180,19 @@ let make_rule r = [None, None, r] (** An entry that checks we reached the end of the input. *) let eoi_entry en = - let e = Entry.create ((Gram.Entry.name en) ^ "_eoi") in - let symbs = G.Rule.next (G.Rule.next G.Rule.stop (G.Symbol.nterm en)) (G.Symbol.token Tok.PEOI) in + let e = Entry.make ((Entry.name en) ^ "_eoi") in + let symbs = Rule.next (Rule.next Rule.stop (Symbol.nterm en)) (Symbol.token Tok.PEOI) in let act = fun _ x loc -> x in - let warning msg = Feedback.msg_warning Pp.(str msg) in - Gram.safe_extend ~warning:(Some warning) e None (make_rule [G.Production.make symbs act]); + let ext = { pos = None; data = make_rule [Production.make symbs act] } in + safe_extend e ext; e let map_entry f en = - let e = Entry.create ((Gram.Entry.name en) ^ "_map") in - let symbs = G.Rule.next G.Rule.stop (G.Symbol.nterm en) in + let e = Entry.make ((Entry.name en) ^ "_map") in + let symbs = Rule.next Rule.stop (Symbol.nterm en) in let act = fun x loc -> f x in - let warning msg = Feedback.msg_warning Pp.(str msg) in - Gram.safe_extend ~warning:(Some warning) e None (make_rule [G.Production.make symbs act]); + let ext = { pos = None; data = make_rule [Production.make symbs act] } in + safe_extend e ext; e (* Parse a string, does NOT check if the entire string was read @@ -393,7 +200,7 @@ let map_entry f en = let parse_string f ?loc x = let strm = Stream.of_string x in - Gram.entry_parse f (Gram.coq_parsable ?loc strm) + Entry.parse f (Parsable.make ?loc strm) type gram_universe = string @@ -414,7 +221,7 @@ let get_univ u = let new_entry u s = let ename = u ^ ":" ^ s in - let e = Entry.create ename in + let e = Entry.make ename in e let make_gen_entry u s = new_entry u s @@ -462,6 +269,7 @@ module Prim = let ident = gec_gen "ident" let natural = gec_gen "natural" let integer = gec_gen "integer" + let bignat = Entry.create "Prim.bignat" let bigint = Entry.create "Prim.bigint" let string = gec_gen "string" let lstring = Entry.create "Prim.lstring" @@ -529,13 +337,11 @@ module Module = let module_type = Entry.create "module_type" end -let epsilon_value (type s tr a) f (e : (s, tr, a) symbol) = - let s = symbol_of_prod_entry_key e in - let r = G.Production.make (G.Rule.next G.Rule.stop s) (fun x _ -> f x) in - let ext = [None, None, [r]] in - let entry = Gram.entry_create "epsilon" in - let warning msg = Feedback.msg_warning Pp.(str msg) in - let () = G.safe_extend ~warning:(Some warning) entry None ext in +let epsilon_value (type s tr a) f (e : (s, tr, a) Symbol.t) = + let r = Production.make (Rule.next Rule.stop e) (fun x _ -> f x) in + let entry = Entry.make "epsilon" in + let ext = { pos = None; data = [None, None, [r]] } in + let () = safe_extend entry ext in try Some (parse_string entry "") with _ -> None (** Synchronized grammar extensions *) @@ -593,14 +399,14 @@ let extend_grammar_command tag g = let nb = List.length rules in grammar_stack := (GramExt (nb, GrammarCommand.Dyn (tag, g)), st) :: !grammar_stack -let extend_entry_command (type a) (type b) (tag : (a, b) entry_command) (g : a) : b Gram.Entry.t list = +let extend_entry_command (type a) (type b) (tag : (a, b) entry_command) (g : a) : b Entry.t list = let EntryInterp.Ex modify = EntryInterpMap.find tag !entry_interp in let grammar_state = match !grammar_stack with | [] -> GramState.empty | (_, st) :: _ -> st in let (names, st) = modify g grammar_state in - let entries = List.map (fun name -> Gram.entry_create name) names in + let entries = List.map (fun name -> Entry.make name) names in let iter name e = camlp5_state := ByEntry (tag, name, e) :: !camlp5_state; let EntryData.Ex old = @@ -626,7 +432,7 @@ let extend_dyn_grammar (e, _) = match e with (** Registering extra grammar *) -type any_entry = AnyEntry : 'a Gram.Entry.t -> any_entry +type any_entry = AnyEntry : 'a Entry.t -> any_entry let grammar_names : any_entry list String.Map.t ref = ref String.Map.empty diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index cd97ea20fa..90088be307 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -9,30 +9,13 @@ (************************************************************************) open Names -open Extend open Genarg open Constrexpr open Libnames (** The parser of Coq *) -module Parsable : -sig - type t - val make : ?loc:Loc.t -> char Stream.t -> t - (* Get comment parsing information from the Lexer *) - val comment_state : t -> ((int * int) * string) list -end - -module Entry : sig - type 'a t = 'a Extend.entry - val create : string -> 'a t - val parse : 'a t -> Parsable.t -> 'a - val print : Format.formatter -> 'a t -> unit - val of_parser : string -> (Gramlib.Plexing.location_function -> Tok.t Stream.t -> 'a) -> 'a t - val parse_token_stream : 'a t -> Tok.t Stream.t -> 'a - val name : 'a t -> string -end +include Gramlib.Grammar.S with type te = Tok.t and type 'a pattern = 'a Tok.p module Lookahead : sig type t @@ -171,6 +154,7 @@ module Prim : val pattern_ident : Id.t Entry.t val pattern_identref : lident Entry.t val base_ident : Id.t Entry.t + val bignat : string Entry.t val natural : int Entry.t val bigint : string Entry.t val integer : int Entry.t @@ -221,24 +205,11 @@ module Module : val module_type : module_ast Entry.t end -val epsilon_value : ('a -> 'self) -> ('self, _, 'a) Extend.symbol -> 'self option +(** {5 Type-safe grammar extension} *) -(** {5 Extending the parser without synchronization} *) +val epsilon_value : ('a -> 'self) -> ('self, _, 'a) Symbol.t -> 'self option -type gram_reinit = Gramlib.Gramext.g_assoc * Gramlib.Gramext.position -(** Type of reinitialization data *) - -type 'a single_extend_statement = - string option * - (* Level *) - Gramlib.Gramext.g_assoc option * - (* Associativity *) - 'a production_rule list - (* Symbol list with the interpretation function *) - -type 'a extend_statement = - Gramlib.Gramext.position option * - 'a single_extend_statement list +(** {5 Extending the parser without synchronization} *) val grammar_extend : 'a Entry.t -> 'a extend_statement -> unit (** Extend the grammar of Coq, without synchronizing it with the backtracking @@ -256,6 +227,9 @@ type 'a grammar_command (** Type of synchronized parsing extensions. The ['a] type should be marshallable. *) +type gram_reinit = Gramlib.Gramext.g_assoc * Gramlib.Gramext.position +(** Type of reinitialization data *) + type extend_rule = | ExtendRule : 'a Entry.t * 'a extend_statement -> extend_rule | ExtendRuleReinit : 'a Entry.t * gram_reinit * 'a extend_statement -> extend_rule diff --git a/parsing/tok.ml b/parsing/tok.ml index ff4433f18c..b1ceab8822 100644 --- a/parsing/tok.ml +++ b/parsing/tok.ml @@ -17,7 +17,7 @@ type 'c p = | PPATTERNIDENT : string option -> string p | PIDENT : string option -> string p | PFIELD : string option -> string p - | PNUMERAL : NumTok.t option -> NumTok.t p + | PNUMERAL : NumTok.Unsigned.t option -> NumTok.Unsigned.t p | PSTRING : string option -> string p | PLEFTQMARK : unit p | PBULLET : string option -> string p @@ -31,7 +31,7 @@ let pattern_strings : type c. c p -> string * string option = | PIDENT s -> "IDENT", s | PFIELD s -> "FIELD", s | PNUMERAL None -> "NUMERAL", None - | PNUMERAL (Some n) -> "NUMERAL", Some (NumTok.to_string n) + | PNUMERAL (Some n) -> "NUMERAL", Some (NumTok.Unsigned.sprint n) | PSTRING s -> "STRING", s | PLEFTQMARK -> "LEFTQMARK", None | PBULLET s -> "BULLET", s @@ -43,7 +43,7 @@ type t = | PATTERNIDENT of string | IDENT of string | FIELD of string - | NUMERAL of NumTok.t + | NUMERAL of NumTok.Unsigned.t | STRING of string | LEFTQMARK | BULLET of string @@ -59,7 +59,7 @@ let equal_p (type a b) (t1 : a p) (t2 : b p) : (a, b) Util.eq option = | PIDENT s1, PIDENT s2 when streq s1 s2 -> Some Util.Refl | PFIELD s1, PFIELD s2 when streq s1 s2 -> Some Util.Refl | PNUMERAL None, PNUMERAL None -> Some Util.Refl - | PNUMERAL (Some n1), PNUMERAL (Some n2) when NumTok.equal n1 n2 -> Some Util.Refl + | PNUMERAL (Some n1), PNUMERAL (Some n2) when NumTok.Unsigned.equal n1 n2 -> Some Util.Refl | PSTRING s1, PSTRING s2 when streq s1 s2 -> Some Util.Refl | PLEFTQMARK, PLEFTQMARK -> Some Util.Refl | PBULLET s1, PBULLET s2 when streq s1 s2 -> Some Util.Refl @@ -73,7 +73,7 @@ let equal t1 t2 = match t1, t2 with | PATTERNIDENT s1, PATTERNIDENT s2 -> string_equal s1 s2 | IDENT s1, IDENT s2 -> string_equal s1 s2 | FIELD s1, FIELD s2 -> string_equal s1 s2 -| NUMERAL n1, NUMERAL n2 -> NumTok.equal n1 n2 +| NUMERAL n1, NUMERAL n2 -> NumTok.Unsigned.equal n1 n2 | STRING s1, STRING s2 -> string_equal s1 s2 | LEFTQMARK, LEFTQMARK -> true | BULLET s1, BULLET s2 -> string_equal s1 s2 @@ -100,7 +100,7 @@ let extract_string diff_mode = function else s | PATTERNIDENT s -> s | FIELD s -> if diff_mode then "." ^ s else s - | NUMERAL n -> NumTok.to_string n + | NUMERAL n -> NumTok.Unsigned.sprint n | LEFTQMARK -> "?" | BULLET s -> s | QUOTATION(_,s) -> s @@ -124,7 +124,7 @@ let match_pattern (type c) (p : c p) : t -> c = let err () = raise Stream.Failure in let seq = string_equal in match p with - | PKEYWORD s -> (function KEYWORD s' when seq s s' -> s' | NUMERAL n when seq s (NumTok.to_string n) -> s | _ -> err ()) + | PKEYWORD s -> (function KEYWORD s' when seq s s' -> s' | NUMERAL n when seq s (NumTok.Unsigned.sprint n) -> s | _ -> err ()) | PIDENT None -> (function IDENT s' -> s' | _ -> err ()) | PIDENT (Some s) -> (function (IDENT s' | KEYWORD s') when seq s s' -> s' | _ -> err ()) | PPATTERNIDENT None -> (function PATTERNIDENT s -> s | _ -> err ()) @@ -132,7 +132,7 @@ let match_pattern (type c) (p : c p) : t -> c = | PFIELD None -> (function FIELD s -> s | _ -> err ()) | PFIELD (Some s) -> (function FIELD s' when seq s s' -> s' | _ -> err ()) | PNUMERAL None -> (function NUMERAL s -> s | _ -> err ()) - | PNUMERAL (Some n) -> let s = NumTok.to_string n in (function NUMERAL n' when s = NumTok.to_string n' -> n' | _ -> err ()) + | PNUMERAL (Some n) -> let s = NumTok.Unsigned.sprint n in (function NUMERAL n' when s = NumTok.Unsigned.sprint n' -> n' | _ -> err ()) | PSTRING None -> (function STRING s -> s | _ -> err ()) | PSTRING (Some s) -> (function STRING s' when seq s s' -> s' | _ -> err ()) | PLEFTQMARK -> (function LEFTQMARK -> () | _ -> err ()) diff --git a/parsing/tok.mli b/parsing/tok.mli index 6d0691a746..b556194eb3 100644 --- a/parsing/tok.mli +++ b/parsing/tok.mli @@ -15,7 +15,7 @@ type 'c p = | PPATTERNIDENT : string option -> string p | PIDENT : string option -> string p | PFIELD : string option -> string p - | PNUMERAL : NumTok.t option -> NumTok.t p + | PNUMERAL : NumTok.Unsigned.t option -> NumTok.Unsigned.t p | PSTRING : string option -> string p | PLEFTQMARK : unit p | PBULLET : string option -> string p @@ -29,7 +29,7 @@ type t = | PATTERNIDENT of string | IDENT of string | FIELD of string - | NUMERAL of NumTok.t + | NUMERAL of NumTok.Unsigned.t | STRING of string | LEFTQMARK | BULLET of string diff --git a/plugins/firstorder/g_ground.mlg b/plugins/firstorder/g_ground.mlg index 0133a02ca7..49e4c91182 100644 --- a/plugins/firstorder/g_ground.mlg +++ b/plugins/firstorder/g_ground.mlg @@ -47,7 +47,7 @@ let ()= let default_intuition_tac = - let tac _ _ = Auto.h_auto None [] None in + let tac _ _ = Auto.h_auto None [] (Some []) in let name = { Tacexpr.mltac_plugin = "ground_plugin"; mltac_tactic = "auto_with"; } in let entry = { Tacexpr.mltac_name = name; mltac_index = 0 } in Tacenv.register_ml_tactic name [| tac |]; diff --git a/plugins/funind/functional_principles_types.ml b/plugins/funind/functional_principles_types.ml index 275468ad3d..163645b719 100644 --- a/plugins/funind/functional_principles_types.ml +++ b/plugins/funind/functional_principles_types.ml @@ -63,14 +63,14 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = (* observe (str "princ_infos : " ++ pr_elim_scheme princ_type_info); *) let change_predicate_sort i decl = let new_sort = sorts.(i) in - let args,_ = decompose_prod (EConstr.Unsafe.to_constr (RelDecl.get_type decl)) in + let args,_ = decompose_prod_assum (EConstr.Unsafe.to_constr (RelDecl.get_type decl)) in let real_args = if princ_type_info.indarg_in_concl then List.tl args else args in Context.Named.Declaration.LocalAssum (map_annot Nameops.Name.get_id (Context.Rel.Declaration.get_annot decl), - Term.compose_prod real_args (mkSort new_sort)) + Term.it_mkProd_or_LetIn (mkSort new_sort) real_args) in let new_predicates = List.map_i diff --git a/plugins/funind/gen_principle.ml b/plugins/funind/gen_principle.ml index 7bddbc994f..568dfbe0f1 100644 --- a/plugins/funind/gen_principle.ml +++ b/plugins/funind/gen_principle.ml @@ -39,7 +39,7 @@ let build_newrecursive lnameargsardef = List.fold_left (fun (env,impls) { Vernacexpr.fname={CAst.v=recname}; binders; rtype } -> let arityc = Constrexpr_ops.mkCProdN binders rtype in - let arity,ctx = Constrintern.interp_type env0 sigma arityc in + let arity,_ctx = Constrintern.interp_type env0 sigma arityc in let evd = Evd.from_env env0 in let evd, (_, (_, impls')) = Constrintern.interp_context_evars ~program_mode:false env evd binders in let impl = Constrintern.compute_internalization_data env0 evd Constrintern.Recursive arity impls' in @@ -164,7 +164,7 @@ let prepare_body { Vernacexpr.binders } rt = let fun_args,rt' = chop_rlambda_n n rt in (fun_args,rt') -let build_functional_principle ?(opaque=Proof_global.Transparent) (evd:Evd.evar_map ref) interactive_proof old_princ_type sorts funs i proof_tac hook = +let build_functional_principle ?(opaque=Proof_global.Transparent) (evd:Evd.evar_map ref) old_princ_type sorts funs _i proof_tac hook = (* First we get the type of the old graph principle *) let mutr_nparams = (Tactics.compute_elim_sig !evd (EConstr.of_constr old_princ_type)).Tactics.nparams in (* let time1 = System.get_time () in *) @@ -199,7 +199,7 @@ let build_functional_principle ?(opaque=Proof_global.Transparent) (evd:Evd.evar_ (* end; *) let open Proof_global in - let { name; entries } = Lemmas.pf_fold (close_proof ~opaque ~keep_body_ucst_separate:false (fun x -> x)) lemma in + let { entries } = Lemmas.pf_fold (close_proof ~opaque ~keep_body_ucst_separate:false (fun x -> x)) lemma in match entries with | [entry] -> entry, hook @@ -235,7 +235,6 @@ let change_property_sort evd toSort princ princName = (List.map (fun d -> Termops.map_rel_decl EConstr.Unsafe.to_constr d) princ_info.Tactics.params) let generate_functional_principle (evd: Evd.evar_map ref) - interactive_proof old_princ_type sorts new_princ_name funs i proof_tac = try @@ -283,26 +282,25 @@ let generate_functional_principle (evd: Evd.evar_map ref) register_with_sort Sorts.InSet in let entry, hook = - build_functional_principle evd interactive_proof old_princ_type new_sorts funs i + build_functional_principle evd old_princ_type new_sorts funs i proof_tac hook in (* Pr 1278 : Don't forget to close the goal if an error is raised !!!! *) let uctx = Evd.evar_universe_context sigma in - let hook_data = hook, uctx, [] in - let _ : Names.GlobRef.t = DeclareDef.declare_definition - ~name:new_princ_name ~hook_data + let _ : Names.GlobRef.t = DeclareDef.declare_entry + ~name:new_princ_name ~hook ~scope:(DeclareDef.Global Declare.ImportDefaultBehavior) ~kind:Decls.(IsProof Theorem) - UnivNames.empty_binders - entry [] in + ~impargs:[] + ~uctx entry in () with e when CErrors.noncritical e -> raise (Defining_principle e) let generate_principle (evd:Evd.evar_map ref) pconstants on_error - is_general do_built fix_rec_l recdefs interactive_proof + is_general do_built fix_rec_l recdefs (continue_proof : int -> Names.Constant.t array -> EConstr.constr array -> int -> Tacmach.tactic) : unit = let names = List.map (function { Vernacexpr.fname = {CAst.v=name} } -> name) fix_rec_l in @@ -335,7 +333,7 @@ let generate_principle (evd:Evd.evar_map ref) pconstants on_error let funs_kn = Array.of_list (List.map fname_kn fix_rec_l) in let _ = List.map_i - (fun i x -> + (fun i _x -> let env = Global.env () in let princ = Indrec.lookup_eliminator env (ind_kn,i) (Sorts.InProp) in let evd = ref (Evd.from_env env) in @@ -346,7 +344,6 @@ let generate_principle (evd:Evd.evar_map ref) pconstants on_error let princ_type = EConstr.Unsafe.to_constr princ_type in generate_functional_principle evd - interactive_proof princ_type None None @@ -374,7 +371,6 @@ let register_struct is_rec fixpoint_exprl = | None -> CErrors.user_err ~hdr:"Function" Pp.(str "Body of Function must be given") in ComDefinition.do_definition - ~program_mode:false ~name:fname.CAst.v ~poly:false ~scope:(DeclareDef.Global Declare.ImportDefaultBehavior) @@ -412,7 +408,7 @@ let register_struct is_rec fixpoint_exprl = None,evd,List.rev rev_pconstants let generate_correction_proof_wf f_ref tcc_lemma_ref - is_mes functional_ref eq_ref rec_arg_num rec_arg_type nb_args relation + is_mes functional_ref eq_ref rec_arg_num rec_arg_type relation (_: int) (_:Names.Constant.t array) (_:EConstr.constr array) (_:int) : Tacmach.tactic = Functional_principles_proofs.prove_principle_for_gen (f_ref,functional_ref,eq_ref) @@ -430,7 +426,7 @@ let generate_correction_proof_wf f_ref tcc_lemma_ref res = fv \rightarrow graph\ x_1\ldots x_n\ res\] decomposed as the context and the conclusion *) -let generate_type evd g_to_f f graph i = +let generate_type evd g_to_f f graph = let open Context.Rel.Declaration in let open EConstr in let open EConstr.Vars in @@ -498,7 +494,7 @@ let generate_type evd g_to_f f graph i = WARNING: while convertible, [type_of body] and [type] can be non equal *) let find_induction_principle evd f = - let f_as_constant,u = match EConstr.kind !evd f with + let f_as_constant, _u = match EConstr.kind !evd f with | Constr.Const c' -> c' | _ -> CErrors.user_err Pp.(str "Must be used with a function") in @@ -545,7 +541,7 @@ let rec generate_fresh_id x avoid i = let id = Namegen.next_ident_away_in_goal x (Id.Set.of_list avoid) in id::(generate_fresh_id x (id::avoid) (pred i)) -let prove_fun_correct evd funs_constr graphs_constr schemes lemmas_types_infos i : Tacmach.tactic = +let prove_fun_correct evd graphs_constr schemes lemmas_types_infos i : Tacmach.tactic = let open Constr in let open EConstr in let open Context.Rel.Declaration in @@ -1140,7 +1136,7 @@ let get_funs_constant mp = to prevent Reset strange thing *) let l_bodies = List.map find_constant_body (Array.to_list (Array.map fst l_const)) in - let l_params,l_fixes = List.split (List.map Term.decompose_lam l_bodies) in + let l_params, _l_fixes = List.split (List.map Term.decompose_lam l_bodies) in (* all the parameters must be equal*) let _check_params = let first_params = List.hd l_params in @@ -1240,7 +1236,7 @@ let make_scheme evd (fas : (Constr.pconstant * Sorts.family) list) : Evd.side_ef in let entry, _hook = try - build_functional_principle ~opaque evd false + build_functional_principle ~opaque evd first_type (Array.of_list sorts) this_block_funs @@ -1261,7 +1257,7 @@ let make_scheme evd (fas : (Constr.pconstant * Sorts.family) list) : Evd.side_ef let sorts = Array.of_list sorts in List.map (Functional_principles_types.compute_new_princ_type_from_rel funs sorts) other_princ_types in - let first_princ_body,first_princ_type = Declare.(entry.proof_entry_body, entry.proof_entry_type) in + let first_princ_body = entry.Declare.proof_entry_body in let ctxt,fix = Term.decompose_lam_assum (fst(fst(Future.force first_princ_body))) in (* the principle has for forall ...., fix .*) let (idxs,_),(_,ta,_ as decl) = Constr.destFix fix in let other_result = @@ -1291,7 +1287,6 @@ let make_scheme evd (fas : (Constr.pconstant * Sorts.family) list) : Evd.side_ef let entry, _hook = build_functional_principle evd - false (List.nth other_princ_types (!i - 1)) (Array.of_list sorts) this_block_funs @@ -1330,9 +1325,8 @@ let derive_correctness (funs: Constr.pconstant list) (graphs:inductive list) = let lemmas_types_infos = Util.Array.map2_i (fun i f_constr graph -> - (* let const_of_f,u = destConst f_constr in *) let (type_of_lemma_ctxt,type_of_lemma_concl,graph) = - generate_type evd false f_constr graph i + generate_type evd false f_constr graph in let type_info = (type_of_lemma_ctxt,type_of_lemma_concl) in graphs_constr.(i) <- graph; @@ -1367,7 +1361,7 @@ let derive_correctness (funs: Constr.pconstant list) (graphs:inductive list) = ) in let proving_tac = - prove_fun_correct !evd funs_constr graphs_constr schemes lemmas_types_infos + prove_fun_correct !evd graphs_constr schemes lemmas_types_infos in Array.iteri (fun i f_as_constant -> @@ -1397,8 +1391,8 @@ let derive_correctness (funs: Constr.pconstant list) (graphs:inductive list) = let lemmas_types_infos = Util.Array.map2_i (fun i f_constr graph -> - let (type_of_lemma_ctxt,type_of_lemma_concl,graph) = - generate_type evd true f_constr graph i + let (type_of_lemma_ctxt,type_of_lemma_concl,graph) = + generate_type evd true f_constr graph in let type_info = (type_of_lemma_ctxt,type_of_lemma_concl) in graphs_constr.(i) <- graph; @@ -1414,7 +1408,7 @@ let derive_correctness (funs: Constr.pconstant list) (graphs:inductive list) = in let (kn,_) as graph_ind,u = (destInd !evd graphs_constr.(0)) in - let mib,mip = Global.lookup_inductive graph_ind in + let mib, _mip = Global.lookup_inductive graph_ind in let sigma, scheme = (Indrec.build_mutual_induction_scheme (Global.env ()) !evd (Array.to_list @@ -1484,7 +1478,7 @@ let derive_inversion fix_names = *) List.iter (fun c -> ignore (find_Function_infos (fst c))) fix_names_as_constant ; try - let evd', lind = + let _evd', lind = List.fold_right (fun id (evd,l) -> let evd,id = @@ -1535,11 +1529,11 @@ let register_wf interactive_proof ?(is_mes=false) fname rec_impls wf_rel_expr wf in let eq = Constrexpr_ops.mkCProdN args unbounded_eq in let hook ((f_ref,_) as fconst) tcc_lemma_ref (functional_ref,_) (eq_ref,_) rec_arg_num rec_arg_type - nb_args relation = + _nb_args relation = try pre_hook [fconst] (generate_correction_proof_wf f_ref tcc_lemma_ref is_mes - functional_ref eq_ref rec_arg_num rec_arg_type nb_args relation + functional_ref eq_ref rec_arg_num rec_arg_type relation ); derive_inversion [fname] with e when CErrors.noncritical e -> @@ -1561,7 +1555,7 @@ let register_mes interactive_proof fname rec_impls wf_mes_expr wf_rel_expr_opt w | None -> begin match args with - | [Constrexpr.CLocalAssum ([{CAst.v=Name x}],k,t)] -> t,x + | [Constrexpr.CLocalAssum ([{CAst.v=Name x}],_k,t)] -> t,x | _ -> CErrors.user_err (Pp.str "Recursive argument must be specified") end | Some wf_args -> @@ -1569,7 +1563,7 @@ let register_mes interactive_proof fname rec_impls wf_mes_expr wf_rel_expr_opt w match List.find (function - | Constrexpr.CLocalAssum(l,k,t) -> + | Constrexpr.CLocalAssum(l,_k,t) -> List.exists (function {CAst.v=Name id} -> Id.equal id wf_args | _ -> false) l @@ -1577,7 +1571,7 @@ let register_mes interactive_proof fname rec_impls wf_mes_expr wf_rel_expr_opt w ) args with - | Constrexpr.CLocalAssum(_,k,t) -> t,wf_args + | Constrexpr.CLocalAssum(_,_k,t) -> t,wf_args | _ -> assert false with Not_found -> assert false in @@ -1625,7 +1619,7 @@ let do_generate_principle_aux pconstants on_error register_built interactive_pro let lemma, _is_struct = match fixpoint_exprl with | [{ Vernacexpr.rec_order = Some {CAst.v = Constrexpr.CWfRec (wf_x,wf_rel)} } as fixpoint_expr] -> - let { Vernacexpr.fname; univs; binders; rtype; body_def } as fixpoint_expr = + let { Vernacexpr.fname; univs = _; binders; rtype; body_def } as fixpoint_expr = match recompute_binder_list [fixpoint_expr] with | [e] -> e | _ -> assert false @@ -1644,13 +1638,12 @@ let do_generate_principle_aux pconstants on_error register_built interactive_pro register_built fixpoint_exprl recdefs - true in if register_built then register_wf interactive_proof fname.CAst.v rec_impls wf_rel wf_x.CAst.v using_lemmas binders rtype body pre_hook, false else None, false | [{ Vernacexpr.rec_order = Some {CAst.v = Constrexpr.CMeasureRec(wf_x,wf_mes,wf_rel_opt)} } as fixpoint_expr] -> - let { Vernacexpr.fname; univs; binders; rtype; body_def} as fixpoint_expr = + let { Vernacexpr.fname; univs = _; binders; rtype; body_def} as fixpoint_expr = match recompute_binder_list [fixpoint_expr] with | [e] -> e | _ -> assert false @@ -1671,7 +1664,6 @@ let do_generate_principle_aux pconstants on_error register_built interactive_pro register_built fixpoint_exprl recdefs - true in if register_built then register_mes interactive_proof fname.CAst.v rec_impls wf_mes wf_rel_opt @@ -1689,7 +1681,7 @@ let do_generate_principle_aux pconstants on_error register_built interactive_pro let fixpoint_exprl = recompute_binder_list fixpoint_exprl in let fix_names = List.map (function { Vernacexpr.fname } -> fname.CAst.v) fixpoint_exprl in (* ok all the expressions are structural *) - let recdefs,rec_impls = build_newrecursive fixpoint_exprl in + let recdefs, _rec_impls = build_newrecursive fixpoint_exprl in let is_rec = List.exists (is_rec fix_names) recdefs in let lemma,evd,pconstants = if register_built @@ -1705,7 +1697,6 @@ let do_generate_principle_aux pconstants on_error register_built interactive_pro register_built fixpoint_exprl recdefs - interactive_proof (Functional_principles_proofs.prove_princ_for_struct evd interactive_proof); if register_built then begin derive_inversion fix_names; end; @@ -2066,7 +2057,6 @@ let build_case_scheme fa = *) generate_functional_principle (ref (Evd.from_env (Global.env ()))) - false scheme_type (Some ([|sorts|])) (Some princ_name) diff --git a/plugins/funind/glob_term_to_relation.ml b/plugins/funind/glob_term_to_relation.ml index c7dfe69fb1..e08ad9af3a 100644 --- a/plugins/funind/glob_term_to_relation.ml +++ b/plugins/funind/glob_term_to_relation.ml @@ -1517,7 +1517,7 @@ let do_build_inductive in let msg = str "while trying to define"++ spc () ++ - Ppvernac.pr_vernac (CAst.make Vernacexpr.{ control = []; attrs = []; expr = VernacInductive(None,false,Vernacexpr.Inductive_kw,repacked_rel_inds)}) + Ppvernac.pr_vernac (CAst.make Vernacexpr.{ control = []; attrs = []; expr = VernacInductive(Vernacexpr.Inductive_kw,repacked_rel_inds)}) ++ fnl () ++ msg in @@ -1532,7 +1532,7 @@ let do_build_inductive in let msg = str "while trying to define"++ spc () ++ - Ppvernac.pr_vernac (CAst.make @@ Vernacexpr.{ control = []; attrs = []; expr = VernacInductive(None,false,Vernacexpr.Inductive_kw,repacked_rel_inds)}) + Ppvernac.pr_vernac (CAst.make @@ Vernacexpr.{ control = []; attrs = []; expr = VernacInductive(Vernacexpr.Inductive_kw,repacked_rel_inds)}) ++ fnl () ++ CErrors.print reraise in diff --git a/plugins/ltac/g_tactic.mlg b/plugins/ltac/g_tactic.mlg index 5bfbe7a49a..6a158bde17 100644 --- a/plugins/ltac/g_tactic.mlg +++ b/plugins/ltac/g_tactic.mlg @@ -125,7 +125,7 @@ let destruction_arg_of_constr (c,lbind as clbind) = match lbind with | _ -> ElimOnConstr clbind let mkNumeral n = - Numeral ((if 0<=n then SPlus else SMinus),NumTok.int (string_of_int (abs n))) + Numeral (NumTok.Signed.of_int_string (string_of_int n)) let mkTacCase with_evar = function | [(clear,ElimOnConstr cl),(None,None),None],None -> @@ -185,10 +185,6 @@ let merge_occurrences loc cl = function in (Some p, ans) -let warn_deprecated_eqn_syntax = - CWarnings.create ~name:"deprecated-eqn-syntax" ~category:"deprecated" - (fun arg -> strbrk (Printf.sprintf "Syntax \"_eqn:%s\" is deprecated. Please use \"eqn:%s\" instead." arg arg)) - (* Auxiliary grammar rules *) open Pvernac.Vernac_ @@ -461,10 +457,6 @@ GRAMMAR EXTEND Gram ; eqn_ipat: [ [ IDENT "eqn"; ":"; pat = naming_intropattern -> { Some (CAst.make ~loc pat) } - | IDENT "_eqn"; ":"; pat = naming_intropattern -> - { warn_deprecated_eqn_syntax ~loc "H"; Some (CAst.make ~loc pat) } - | IDENT "_eqn" -> - { warn_deprecated_eqn_syntax ~loc "?"; Some (CAst.make ~loc IntroAnonymous) } | -> { None } ] ] ; as_name: diff --git a/plugins/ltac/tacentries.ml b/plugins/ltac/tacentries.ml index 4af5699317..4127d28bae 100644 --- a/plugins/ltac/tacentries.ml +++ b/plugins/ltac/tacentries.ml @@ -44,11 +44,11 @@ let coincide s pat off = !break let atactic n = - if n = 5 then Aentry Pltac.binder_tactic - else Aentryl (Pltac.tactic_expr, string_of_int n) + if n = 5 then Pcoq.Symbol.nterm Pltac.binder_tactic + else Pcoq.Symbol.nterml Pltac.tactic_expr (string_of_int n) type entry_name = EntryName : - 'a raw_abstract_argument_type * (Tacexpr.raw_tactic_expr, _, 'a) Extend.symbol -> entry_name + 'a raw_abstract_argument_type * (Tacexpr.raw_tactic_expr, _, 'a) Pcoq.Symbol.t -> entry_name (** Quite ad-hoc *) let get_tacentry n m = @@ -57,8 +57,8 @@ let get_tacentry n m = && not (Int.equal m 5) (* Because tactic5 is at binder_tactic *) && not (Int.equal m 0) (* Because tactic0 is at simple_tactic *) in - if check_lvl n then EntryName (rawwit Tacarg.wit_tactic, Aself) - else if check_lvl (n + 1) then EntryName (rawwit Tacarg.wit_tactic, Anext) + if check_lvl n then EntryName (rawwit Tacarg.wit_tactic, Pcoq.Symbol.self) + else if check_lvl (n + 1) then EntryName (rawwit Tacarg.wit_tactic, Pcoq.Symbol.next) else EntryName (rawwit Tacarg.wit_tactic, atactic n) let get_separator = function @@ -140,23 +140,23 @@ let head_is_ident tg = match tg.tacgram_prods with let rec prod_item_of_symbol lev = function | Extend.Ulist1 s -> let EntryName (Rawwit typ, e) = prod_item_of_symbol lev s in - EntryName (Rawwit (ListArg typ), Alist1 e) + EntryName (Rawwit (ListArg typ), Pcoq.Symbol.list1 e) | Extend.Ulist0 s -> let EntryName (Rawwit typ, e) = prod_item_of_symbol lev s in - EntryName (Rawwit (ListArg typ), Alist0 e) + EntryName (Rawwit (ListArg typ), Pcoq.Symbol.list0 e) | Extend.Ulist1sep (s, sep) -> let EntryName (Rawwit typ, e) = prod_item_of_symbol lev s in - EntryName (Rawwit (ListArg typ), Alist1sep (e, Atoken (CLexer.terminal sep))) + EntryName (Rawwit (ListArg typ), Pcoq.Symbol.list1sep e (Pcoq.Symbol.token (CLexer.terminal sep)) false) | Extend.Ulist0sep (s, sep) -> let EntryName (Rawwit typ, e) = prod_item_of_symbol lev s in - EntryName (Rawwit (ListArg typ), Alist0sep (e, Atoken (CLexer.terminal sep))) + EntryName (Rawwit (ListArg typ), Pcoq.Symbol.list0sep e (Pcoq.Symbol.token (CLexer.terminal sep)) false) | Extend.Uopt s -> let EntryName (Rawwit typ, e) = prod_item_of_symbol lev s in - EntryName (Rawwit (OptArg typ), Aopt e) + EntryName (Rawwit (OptArg typ), Pcoq.Symbol.opt e) | Extend.Uentry arg -> let ArgT.Any tag = arg in let wit = ExtraArg tag in - EntryName (Rawwit wit, Extend.Aentry (genarg_grammar wit)) + EntryName (Rawwit wit, Pcoq.Symbol.nterm (genarg_grammar wit)) | Extend.Uentryl (s, n) -> let ArgT.Any tag = s in assert (coincide (ArgT.repr tag) "tactic" 0); @@ -191,7 +191,7 @@ let add_tactic_entry (kn, ml, tg) state = in let prods = List.map map tg.tacgram_prods in let rules = make_rule mkact prods in - let r = ExtendRule (entry, (pos, [(None, None, [rules])])) in + let r = ExtendRule (entry, { pos; data=[(None, None, [rules])]}) in ([r], state) let tactic_grammar = @@ -399,23 +399,29 @@ let create_ltac_quotation name cast (e, l) = in let () = ltac_quotations := String.Set.add name !ltac_quotations in let entry = match l with - | None -> Aentry e - | Some l -> Aentryl (e, string_of_int l) + | None -> Pcoq.Symbol.nterm e + | Some l -> Pcoq.Symbol.nterml e (string_of_int l) in (* let level = Some "1" in *) let level = None in let assoc = None in let rule = - Next (Next (Next (Next (Next (Stop, - Atoken (CLexer.terminal name)), - Atoken (CLexer.terminal ":")), - Atoken (CLexer.terminal "(")), - entry), - Atoken (CLexer.terminal ")")) + Pcoq.( + Rule.next + (Rule.next + (Rule.next + (Rule.next + (Rule.next + Rule.stop + (Symbol.token (CLexer.terminal name))) + (Symbol.token (CLexer.terminal ":"))) + (Symbol.token (CLexer.terminal "("))) + entry) + (Symbol.token (CLexer.terminal ")"))) in let action _ v _ _ _ loc = cast (Some loc, v) in - let gram = (level, assoc, [Rule (rule, action)]) in - Pcoq.grammar_extend Pltac.tactic_arg (None, [gram]) + let gram = (level, assoc, [Pcoq.Production.make rule action]) in + Pcoq.grammar_extend Pltac.tactic_arg {pos=None; data=[gram]} (** Command *) @@ -759,7 +765,7 @@ let argument_extend (type a b c) ~name (arg : (a, b, c) tactic_argument) = e | Vernacextend.Arg_rules rules -> let e = Pcoq.create_generic_entry Pcoq.utactic name (Genarg.rawwit wit) in - let () = Pcoq.grammar_extend e (None, [(None, None, rules)]) in + let () = Pcoq.grammar_extend e {pos=None; data=[(None, None, rules)]} in e in let (rpr, gpr, tpr) = arg.arg_printer in diff --git a/plugins/micromega/.ocamlformat b/plugins/micromega/.ocamlformat new file mode 100644 index 0000000000..a22a2ff88c --- /dev/null +++ b/plugins/micromega/.ocamlformat @@ -0,0 +1 @@ +disable=false diff --git a/plugins/micromega/.ocamlformat-ignore b/plugins/micromega/.ocamlformat-ignore new file mode 100644 index 0000000000..157a987754 --- /dev/null +++ b/plugins/micromega/.ocamlformat-ignore @@ -0,0 +1 @@ +micromega.ml diff --git a/plugins/micromega/certificate.ml b/plugins/micromega/certificate.ml index 824abdaf89..1958fff4cc 100644 --- a/plugins/micromega/certificate.ml +++ b/plugins/micromega/certificate.ml @@ -651,10 +651,10 @@ let z_cert_of_pos pos = in simplify_cone z_spec (_cert_of_pos pos) -open Mutils (** All constraints (initial or derived) have an index and have a justification i.e., proof. Given a constraint, all the coefficients are always integers. *) +open Mutils open Polynomial diff --git a/plugins/micromega/certificate.mli b/plugins/micromega/certificate.mli index d8c9ade04d..cabd36ebb7 100644 --- a/plugins/micromega/certificate.mli +++ b/plugins/micromega/certificate.mli @@ -10,36 +10,36 @@ module Mc = Micromega -val use_simplex : bool ref (** [use_simplex] is bound to the Coq option Simplex. If set, use the Simplex method, otherwise use Fourier *) +val use_simplex : bool ref type ('prf, 'model) res = Prf of 'prf | Model of 'model | Unknown type zres = (Mc.zArithProof, int * Mc.z list) res type qres = (Mc.q Mc.psatz, int * Mc.q list) res -val dump_file : string option ref (** [dump_file] is bound to the Coq option Dump Arith. If set to some [file], arithmetic goals are dumped in filexxx.v *) +val dump_file : string option ref -val q_cert_of_pos : Sos_types.positivstellensatz -> Mc.q Mc.psatz (** [q_cert_of_pos prf] converts a Sos proof into a rational Coq proof *) +val q_cert_of_pos : Sos_types.positivstellensatz -> Mc.q Mc.psatz -val z_cert_of_pos : Sos_types.positivstellensatz -> Mc.z Mc.psatz (** [z_cert_of_pos prf] converts a Sos proof into an integer Coq proof *) +val z_cert_of_pos : Sos_types.positivstellensatz -> Mc.z Mc.psatz -val lia : bool -> int -> (Mc.z Mc.pExpr * Mc.op1) list -> zres (** [lia enum depth sys] generates an unsat proof for the linear constraints in [sys]. If the Simplex option is set, any failure to find a proof should be considered as a bug. *) +val lia : bool -> int -> (Mc.z Mc.pExpr * Mc.op1) list -> zres -val nlia : bool -> int -> (Mc.z Mc.pExpr * Mc.op1) list -> zres (** [nlia enum depth sys] generates an unsat proof for the non-linear constraints in [sys]. The solver is incomplete -- the problem is undecidable *) +val nlia : bool -> int -> (Mc.z Mc.pExpr * Mc.op1) list -> zres -val linear_prover_with_cert : int -> (Mc.q Mc.pExpr * Mc.op1) list -> qres (** [linear_prover_with_cert depth sys] generates an unsat proof for the linear constraints in [sys]. Over the rationals, the solver is complete. *) +val linear_prover_with_cert : int -> (Mc.q Mc.pExpr * Mc.op1) list -> qres -val nlinear_prover : int -> (Mc.q Mc.pExpr * Mc.op1) list -> qres (** [nlinear depth sys] generates an unsat proof for the non-linear constraints in [sys]. The solver is incompete -- the problem is decidable. *) +val nlinear_prover : int -> (Mc.q Mc.pExpr * Mc.op1) list -> qres diff --git a/plugins/micromega/coq_micromega.ml b/plugins/micromega/coq_micromega.ml index 87778f7f7b..43f6f5a35e 100644 --- a/plugins/micromega/coq_micromega.ml +++ b/plugins/micromega/coq_micromega.ml @@ -1279,7 +1279,8 @@ module M = struct let dump_expr i e = let rec dump_expr = function | Mc.PEX n -> - EConstr.mkRel (i + List.assoc (CoqToCaml.positive n) vars_idx) + EConstr.mkRel + (i + CList.assoc_f Int.equal (CoqToCaml.positive n) vars_idx) | Mc.PEc z -> dexpr.dump_cst z | Mc.PEadd (e1, e2) -> EConstr.mkApp (dexpr.dump_add, [|dump_expr e1; dump_expr e2|]) @@ -1294,7 +1295,9 @@ module M = struct dump_expr e in let mkop op e1 e2 = - try EConstr.mkApp (List.assoc op dexpr.dump_op, [|e1; e2|]) + try + EConstr.mkApp + (CList.assoc_f Mutils.Hash.eq_op2 op dexpr.dump_op, [|e1; e2|]) with Not_found -> EConstr.mkApp (Lazy.force coq_Eq, [|dexpr.interp_typ; e1; e2|]) in @@ -1473,6 +1476,9 @@ let parse_goal gl parse_arith (env : Env.t) hyps term = let lhyps, env, tg = parse_hyps gl parse_arith env tg hyps in (lhyps, f, env) +(** + * The datastructures that aggregate theory-dependent proof values. + *) type ('synt_c, 'prf) domain_spec = { typ : EConstr.constr ; (* is the type of the interpretation domain - Z, Q, R*) @@ -1480,10 +1486,8 @@ type ('synt_c, 'prf) domain_spec = ; (* is the type of the syntactic coeffs - Z , Q , Rcst *) dump_coeff : 'synt_c -> EConstr.constr ; proof_typ : EConstr.constr - ; dump_proof : 'prf -> EConstr.constr } -(** - * The datastructures that aggregate theory-dependent proof values. - *) + ; dump_proof : 'prf -> EConstr.constr + ; coeff_eq : 'synt_c -> 'synt_c -> bool } let zz_domain_spec = lazy @@ -1491,7 +1495,8 @@ let zz_domain_spec = ; coeff = Lazy.force coq_Z ; dump_coeff = dump_z ; proof_typ = Lazy.force coq_proofTerm - ; dump_proof = dump_proof_term } + ; dump_proof = dump_proof_term + ; coeff_eq = Mc.zeq_bool } let qq_domain_spec = lazy @@ -1499,7 +1504,8 @@ let qq_domain_spec = ; coeff = Lazy.force coq_Q ; dump_coeff = dump_q ; proof_typ = Lazy.force coq_QWitness - ; dump_proof = dump_psatz coq_Q dump_q } + ; dump_proof = dump_psatz coq_Q dump_q + ; coeff_eq = Mc.qeq_bool } let max_tag f = 1 + Tag.to_int (Mc.foldA (fun t1 (t2, _) -> Tag.max t1 t2) f (Tag.from 0)) @@ -1603,7 +1609,12 @@ let witness_list_tags p g = witness_list p g * Prune the proof object, according to the 'diff' between two cnf formulas. *) -let compact_proofs (cnf_ff : 'cst cnf) res (cnf_ff' : 'cst cnf) = +let compact_proofs (eq_cst : 'cst -> 'cst -> bool) (cnf_ff : 'cst cnf) res + (cnf_ff' : 'cst cnf) = + let eq_formula (p1, o1) (p2, o2) = + let open Mutils.Hash in + eq_pol eq_cst p1 p2 && eq_op1 o1 o2 + in let compact_proof (old_cl : 'cst clause) (prf, prover) (new_cl : 'cst clause) = let new_cl = List.mapi (fun i (f, _) -> (f, i)) new_cl in @@ -1611,7 +1622,7 @@ let compact_proofs (cnf_ff : 'cst cnf) res (cnf_ff' : 'cst cnf) = let formula = try fst (List.nth old_cl i) with Failure _ -> failwith "bad old index" in - List.assoc formula new_cl + CList.assoc_f eq_formula formula new_cl in (* if debug then begin @@ -1641,7 +1652,13 @@ let compact_proofs (cnf_ff : 'cst cnf) res (cnf_ff' : 'cst cnf) = (new_cl : 'cst clause) = let hyps_idx = prover.hyps prf in let hyps = selecti hyps_idx old_cl in - is_sublist ( = ) hyps new_cl + let eq (f1, (t1, e1)) (f2, (t2, e2)) = + Int.equal (Tag.compare t1 t2) 0 + && eq_formula f1 f2 + && (e1 : EConstr.t) = (e2 : EConstr.t) + (* FIXME: what equality should we use here? *) + in + is_sublist eq hyps new_cl in let cnf_res = List.combine cnf_ff res in (* we get pairs clause * proof *) @@ -1798,7 +1815,7 @@ let micromega_tauto pre_process cnf spec prover env | None -> failwith "abstraction is wrong" | Some res -> () end ; *) - let res' = compact_proofs cnf_ff res cnf_ff' in + let res' = compact_proofs spec.coeff_eq cnf_ff res cnf_ff' in let ff', res', ids = (ff', res', Mc.ids_of_formula ff') in let res' = dump_list spec.proof_typ spec.dump_proof res' in Prf (ids, ff', res') @@ -1946,7 +1963,8 @@ let micromega_genr prover tac = ; coeff = Lazy.force coq_Rcst ; dump_coeff = dump_q ; proof_typ = Lazy.force coq_QWitness - ; dump_proof = dump_psatz coq_Q dump_q } + ; dump_proof = dump_psatz coq_Q dump_q + ; coeff_eq = Mc.qeq_bool } in Proofview.Goal.enter (fun gl -> let sigma = Tacmach.New.project gl in @@ -1979,7 +1997,7 @@ let micromega_genr prover tac = | Prf (ids, ff', res') -> let ff, ids = formula_hyps_concl - (List.filter (fun (n, _) -> List.mem n ids) hyps) + (List.filter (fun (n, _) -> CList.mem_f Id.equal n ids) hyps) concl in let ff' = abstract_wrt_formula ff' ff in diff --git a/plugins/micromega/coq_micromega.mli b/plugins/micromega/coq_micromega.mli index f2f7fd424f..679290891d 100644 --- a/plugins/micromega/coq_micromega.mli +++ b/plugins/micromega/coq_micromega.mli @@ -24,5 +24,5 @@ val print_lia_profile : unit -> unit (** {5 Use Micromega independently from tactics. } *) -val dump_proof_term : Micromega.zArithProof -> EConstr.t (** [dump_proof_term] generates the Coq representation of a Micromega proof witness *) +val dump_proof_term : Micromega.zArithProof -> EConstr.t diff --git a/plugins/micromega/mfourier.ml b/plugins/micromega/mfourier.ml index 5ed7d9865e..3d1770a541 100644 --- a/plugins/micromega/mfourier.ml +++ b/plugins/micromega/mfourier.ml @@ -17,8 +17,8 @@ open Vect let debug = false let compare_float (p : float) q = pervasives_compare p q -open Itv (** Implementation of intervals *) +open Itv type vector = Vect.t @@ -47,8 +47,8 @@ and cstr_info = {bound : interval; prf : proof; pos : int; neg : int} [v] is an upper-bound of the set of variables which appear in [s]. *) -exception SystemContradiction of proof (** To be thrown when a system has no solution *) +exception SystemContradiction of proof (** Pretty printing *) let rec pp_proof o prf = diff --git a/plugins/micromega/mutils.ml b/plugins/micromega/mutils.ml index f9a23751bf..27b917383b 100644 --- a/plugins/micromega/mutils.ml +++ b/plugins/micromega/mutils.ml @@ -385,7 +385,13 @@ module Hash = struct let int_of_eq_op1 = Mc.(function Equal -> 0 | NonEqual -> 1 | Strict -> 2 | NonStrict -> 3) - let eq_op1 o1 o2 = int_of_eq_op1 o1 = int_of_eq_op1 o2 + let int_of_eq_op2 = + Mc.( + function + | OpEq -> 0 | OpNEq -> 1 | OpLe -> 2 | OpGe -> 3 | OpLt -> 4 | OpGt -> 5) + + let eq_op1 o1 o2 = Int.equal (int_of_eq_op1 o1) (int_of_eq_op1 o2) + let eq_op2 o1 o2 = Int.equal (int_of_eq_op2 o1) (int_of_eq_op2 o2) let hash_op1 h o = combine h (int_of_eq_op1 o) let rec eq_positive p1 p2 = diff --git a/plugins/micromega/mutils.mli b/plugins/micromega/mutils.mli index 5e0c913996..09d55cf073 100644 --- a/plugins/micromega/mutils.mli +++ b/plugins/micromega/mutils.mli @@ -26,8 +26,8 @@ end module IMap : sig include Map.S with type key = int - val from : key -> 'elt t -> 'elt t (** [from k m] returns the submap of [m] with keys greater or equal k *) + val from : key -> 'elt t -> 'elt t end module Cmp : sig @@ -43,6 +43,7 @@ module Tag : sig val max : t -> t -> t val from : int -> t val to_int : t -> int + val compare : t -> t -> int end module TagSet : CSig.SetS with type elt = Tag.t @@ -73,6 +74,7 @@ end module Hash : sig val eq_op1 : Micromega.op1 -> Micromega.op1 -> bool + val eq_op2 : Micromega.op2 -> Micromega.op2 -> bool val eq_positive : Micromega.positive -> Micromega.positive -> bool val eq_z : Micromega.z -> Micromega.z -> bool val eq_q : Micromega.q -> Micromega.q -> bool diff --git a/plugins/micromega/persistent_cache.mli b/plugins/micromega/persistent_cache.mli index 16d3f0a517..08e8c53757 100644 --- a/plugins/micromega/persistent_cache.mli +++ b/plugins/micromega/persistent_cache.mli @@ -14,25 +14,25 @@ module type PHashtable = sig type 'a t type key - val open_in : string -> 'a t (** [open_in f] rebuilds a table from the records stored in file [f]. As marshaling is not type-safe, it might segfault. *) + val open_in : string -> 'a t - val find : 'a t -> key -> 'a (** find has the specification of Hashtable.find *) + val find : 'a t -> key -> 'a - val add : 'a t -> key -> 'a -> unit (** [add tbl key elem] adds the binding [key] [elem] to the table [tbl]. (and writes the binding to the file associated with [tbl].) If [key] is already bound, raises KeyAlreadyBound *) + val add : 'a t -> key -> 'a -> unit - val memo : string -> (key -> 'a) -> key -> 'a (** [memo cache f] returns a memo function for [f] using file [cache] as persistent table. Note that the cache will only be loaded when the function is used for the first time *) + val memo : string -> (key -> 'a) -> key -> 'a - val memo_cond : string -> (key -> bool) -> (key -> 'a) -> key -> 'a (** [memo cache cond f] only use the cache if [cond k] holds for the key [k]. *) + val memo_cond : string -> (key -> bool) -> (key -> 'a) -> key -> 'a end module PHashtable (Key : HashedType) : PHashtable with type key = Key.t diff --git a/plugins/micromega/polynomial.mli b/plugins/micromega/polynomial.mli index bdd77440bb..9c09f76691 100644 --- a/plugins/micromega/polynomial.mli +++ b/plugins/micromega/polynomial.mli @@ -17,52 +17,52 @@ val max_nb_cstr : int ref type var = int module Monomial : sig - type t (** A monomial is represented by a multiset of variables *) + type t - val fold : (var -> int -> 'a -> 'a) -> t -> 'a -> 'a (** [fold f m acc] folds over the variables with multiplicities *) + val fold : (var -> int -> 'a -> 'a) -> t -> 'a -> 'a - val degree : t -> int (** [degree m] is the sum of the degrees of each variable *) + val degree : t -> int - val const : t (** [const] @return the empty monomial i.e. without any variable *) + val const : t val is_const : t -> bool - val var : var -> t (** [var x] @return the monomial x^1 *) + val var : var -> t - val prod : t -> t -> t (** [prod n m] @return the monomial n*m *) + val prod : t -> t -> t - val sqrt : t -> t option (** [sqrt m] @return [Some r] iff r^2 = m *) + val sqrt : t -> t option - val is_var : t -> bool (** [is_var m] @return [true] iff m = x^1 for some variable x *) + val is_var : t -> bool - val get_var : t -> var option (** [get_var m] @return [x] iff m = x^1 for variable x *) + val get_var : t -> var option - val div : t -> t -> t * int (** [div m1 m2] @return a pair [mr,n] such that mr * (m2)^n = m1 where n is maximum *) + val div : t -> t -> t * int - val compare : t -> t -> int (** [compare m1 m2] provides a total order over monomials*) + val compare : t -> t -> int - val variables : t -> ISet.t (** [variables m] @return the set of variables with (strictly) positive multiplicities *) + val variables : t -> ISet.t end module MonMap : sig @@ -82,36 +82,36 @@ module Poly : sig type t - val constant : Q.t -> t (** [constant c] @return the constant polynomial c *) + val constant : Q.t -> t - val variable : var -> t (** [variable x] @return the polynomial 1.x^1 *) + val variable : var -> t - val addition : t -> t -> t (** [addition p1 p2] @return the polynomial p1+p2 *) + val addition : t -> t -> t - val product : t -> t -> t (** [product p1 p2] @return the polynomial p1*p2 *) + val product : t -> t -> t - val uminus : t -> t (** [uminus p] @return the polynomial -p i.e product by -1 *) + val uminus : t -> t - val get : Monomial.t -> t -> Q.t (** [get mi p] @return the coefficient ai of the monomial mi. *) + val get : Monomial.t -> t -> Q.t - val fold : (Monomial.t -> Q.t -> 'a -> 'a) -> t -> 'a -> 'a (** [fold f p a] folds f over the monomials of p with non-zero coefficient *) + val fold : (Monomial.t -> Q.t -> 'a -> 'a) -> t -> 'a -> 'a - val add : Monomial.t -> Q.t -> t -> t (** [add m n p] @return the polynomial n*m + p *) + val add : Monomial.t -> Q.t -> t -> t end type cstr = {coeffs : Vect.t; op : op; cst : Q.t} @@ -125,9 +125,9 @@ val eval_op : op -> Q.t -> Q.t -> bool val opAdd : op -> op -> op -val is_strict : cstr -> bool (** [is_strict c] @return whether the constraint is strict i.e. c.op = Gt *) +val is_strict : cstr -> bool exception Strict @@ -147,70 +147,70 @@ module LinPoly : sig This is done using the monomial tables of the module MonT. *) module MonT : sig - val clear : unit -> unit (** [clear ()] clears the mapping. *) + val clear : unit -> unit - val reserve : int -> unit (** [reserve i] reserves the integer i *) + val reserve : int -> unit - val get_fresh : unit -> int (** [get_fresh ()] return the first fresh variable *) + val get_fresh : unit -> int - val retrieve : int -> Monomial.t (** [retrieve x] @return the monomial corresponding to the variable [x] *) + val retrieve : int -> Monomial.t - val register : Monomial.t -> int (** [register m] @return the variable index for the monomial m *) + val register : Monomial.t -> int end - val linpol_of_pol : Poly.t -> t (** [linpol_of_pol p] linearise the polynomial p *) + val linpol_of_pol : Poly.t -> t - val var : var -> t (** [var x] @return 1.y where y is the variable index of the monomial x^1. *) + val var : var -> t - val coq_poly_of_linpol : (Q.t -> 'a) -> t -> 'a Mc.pExpr (** [coq_poly_of_linpol c p] @param p is a multi-variate polynomial. @param c maps a rational to a Coq polynomial coefficient. @return the coq expression corresponding to polynomial [p].*) + val coq_poly_of_linpol : (Q.t -> 'a) -> t -> 'a Mc.pExpr - val of_monomial : Monomial.t -> t (** [of_monomial m] @returns 1.x where x is the variable (index) for monomial m *) + val of_monomial : Monomial.t -> t - val of_vect : Vect.t -> t (** [of_vect v] @returns a1.x1 + ... + an.xn This is not the identity because xi is the variable index of xi^1 *) + val of_vect : Vect.t -> t - val variables : t -> ISet.t (** [variables p] @return the set of variables of the polynomial p interpreted as a multi-variate polynomial *) + val variables : t -> ISet.t - val is_variable : t -> var option (** [is_variable p] @return Some x if p = a.x for a >= 0 *) + val is_variable : t -> var option - val is_linear : t -> bool (** [is_linear p] @return whether the multi-variate polynomial is linear. *) + val is_linear : t -> bool - val is_linear_for : var -> t -> bool (** [is_linear_for x p] @return true if the polynomial is linear in x i.e can be written c*x+r where c is a constant and r is independent from x *) + val is_linear_for : var -> t -> bool - val constant : Q.t -> t (** [constant c] @return the constant polynomial c *) + val constant : Q.t -> t (** [search_linear pred p] @return a variable x such p = a.x + b such that @@ -219,44 +219,44 @@ module LinPoly : sig val search_linear : (Q.t -> bool) -> t -> var option - val search_all_linear : (Q.t -> bool) -> t -> var list (** [search_all_linear pred p] @return all the variables x such p = a.x + b such that p is linear in x i.e x does not occur in b and a is a constant such that [pred a] *) + val search_all_linear : (Q.t -> bool) -> t -> var list val get_bound : t -> Vect.Bound.t option - val product : t -> t -> t (** [product p q] @return the product of the polynomial [p*q] *) + val product : t -> t -> t - val factorise : var -> t -> t * t (** [factorise x p] @return [a,b] such that [p = a.x + b] and [x] does not occur in [b] *) + val factorise : var -> t -> t * t - val collect_square : t -> Monomial.t MonMap.t (** [collect_square p] @return a mapping m such that m[s] = s^2 for every s^2 that is a monomial of [p] *) + val collect_square : t -> Monomial.t MonMap.t - val monomials : t -> ISet.t (** [monomials p] @return the set of monomials. *) + val monomials : t -> ISet.t - val degree : t -> int (** [degree p] @return return the maximum degree *) + val degree : t -> int - val pp_var : out_channel -> var -> unit (** [pp_var o v] pretty-prints a monomial indexed by v. *) + val pp_var : out_channel -> var -> unit - val pp : out_channel -> t -> unit (** [pp o p] pretty-prints a polynomial. *) + val pp : out_channel -> t -> unit - val pp_goal : string -> out_channel -> (t * op) list -> unit (** [pp_goal typ o l] pretty-prints the list of constraints as a Coq goal. *) + val pp_goal : string -> out_channel -> (t * op) list -> unit end module ProofFormat : sig @@ -318,47 +318,47 @@ val opMult : op -> op -> op module WithProof : sig type t = (LinPoly.t * op) * ProofFormat.prf_rule - exception InvalidProof (** [InvalidProof] is raised if the operation is invalid. *) + exception InvalidProof val compare : t -> t -> int val annot : string -> t -> t val of_cstr : cstr * ProofFormat.prf_rule -> t - val output : out_channel -> t -> unit (** [out_channel chan c] pretty-prints the constraint [c] over the channel [chan] *) + val output : out_channel -> t -> unit val output_sys : out_channel -> t list -> unit - val zero : t (** [zero] represents the tautology (0=0) *) + val zero : t - val const : Q.t -> t (** [const n] represents the tautology (n>=0) *) + val const : Q.t -> t - val product : t -> t -> t (** [product p q] @return the polynomial p*q with its sign and proof *) + val product : t -> t -> t - val addition : t -> t -> t (** [addition p q] @return the polynomial p+q with its sign and proof *) + val addition : t -> t -> t - val mult : LinPoly.t -> t -> t (** [mult p q] @return the polynomial p*q with its sign and proof. @raise InvalidProof if p is not a constant and p is not an equality *) + val mult : LinPoly.t -> t -> t - val cutting_plane : t -> t option (** [cutting_plane p] does integer reasoning and adjust the constant to be integral *) + val cutting_plane : t -> t option - val linear_pivot : t list -> t -> Vect.var -> t -> t option (** [linear_pivot sys p x q] @return the polynomial [q] where [x] is eliminated using the polynomial [p] The pivoting operation is only defined if - p is linear in x i.e p = a.x+b and x neither occurs in a and b - The pivoting also requires some sign conditions for [a] *) + val linear_pivot : t list -> t -> Vect.var -> t -> t option (** [subst sys] performs the equivalent of the 'subst' tactic of Coq. For every p=0 \in sys such that p is linear in x with coefficient +/- 1 @@ -371,8 +371,8 @@ module WithProof : sig val subst : t list -> t list - val subst1 : t list -> t list (** [subst1 sys] performs a single substitution *) + val subst1 : t list -> t list val saturate_subst : bool -> t list -> t list val is_substitution : bool -> t -> var option diff --git a/plugins/micromega/simplex.ml b/plugins/micromega/simplex.ml index 702099a95d..eaa26ded62 100644 --- a/plugins/micromega/simplex.ml +++ b/plugins/micromega/simplex.ml @@ -62,9 +62,9 @@ let get_profile_info () = type iset = unit IMap.t -type tableau = Vect.t IMap.t (** Mapping basic variables to their equation. All variables >= than a threshold rst are restricted.*) +type tableau = Vect.t IMap.t module Restricted = struct type t = @@ -366,9 +366,9 @@ let push_real (opt : bool) (nw : var) (v : Vect.t) (rst : Restricted.t) let v' = safe_find "push_real" nw t' in Unsat (Vect.set nw Q.one (Vect.set 0 Q.zero (Vect.mul Q.neg_one v'))) ) -open Mutils (** One complication is that equalities needs some pre-processing. *) +open Mutils open Polynomial diff --git a/plugins/micromega/vect.ml b/plugins/micromega/vect.ml index 1742f81b34..3e0b1f2cd9 100644 --- a/plugins/micromega/vect.ml +++ b/plugins/micromega/vect.ml @@ -12,14 +12,15 @@ open NumCompat open Q.Notations open Mutils -type var = int (** [t] is the type of vectors. A vector [(x1,v1) ; ... ; (xn,vn)] is such that: - variables indexes are ordered (x1 < ... < xn - values are all non-zero *) +type var = int -type t = (var * Q.t) list +type mono = {var : var; coe : Q.t} +type t = mono list type vector = t (** [equal v1 v2 = true] if the vectors are syntactically equal. *) @@ -29,21 +30,25 @@ let rec equal v1 v2 = | [], [] -> true | [], _ -> false | _ :: _, [] -> false - | (i1, n1) :: v1, (i2, n2) :: v2 -> Int.equal i1 i2 && n1 =/ n2 && equal v1 v2 + | {var = i1; coe = n1} :: v1, {var = i2; coe = n2} :: v2 -> + Int.equal i1 i2 && n1 =/ n2 && equal v1 v2 let hash v = let rec hash i = function | [] -> i - | (vr, vl) :: l -> hash (i + Hashtbl.hash (vr, Q.to_float vl)) l + | {var = vr; coe = vl} :: l -> hash (i + Hashtbl.hash (vr, Q.to_float vl)) l in Hashtbl.hash (hash 0 v) let null = [] let is_null v = - match v with [] -> true | [(0, x)] when Q.zero =/ x -> true | _ -> false + match v with + | [] -> true + | [{var = 0; coe = x}] when Q.zero =/ x -> true + | _ -> false -let pp_var_num pp_var o (v, n) = +let pp_var_num pp_var o {var = v; coe = n} = if Int.equal v 0 then if Q.zero =/ n then () else Printf.fprintf o "%s" (Q.to_string n) else if Q.one =/ n then pp_var o v @@ -51,7 +56,7 @@ let pp_var_num pp_var o (v, n) = else if Q.zero =/ n then () else Printf.fprintf o "%s*%a" (Q.to_string n) pp_var v -let pp_var_num_smt pp_var o (v, n) = +let pp_var_num_smt pp_var o {var = v; coe = n} = if Int.equal v 0 then if Q.zero =/ n then () else Printf.fprintf o "%s" (Q.to_string n) else if Q.one =/ n then pp_var o v @@ -79,7 +84,7 @@ let from_list (l : Q.t list) = match l with | [] -> [] | e :: l -> - if e <>/ Q.zero then (i, e) :: xfrom_list (i + 1) l + if e <>/ Q.zero then {var = i; coe = e} :: xfrom_list (i + 1) l else xfrom_list (i + 1) l in xfrom_list 0 l @@ -88,68 +93,71 @@ let to_list m = let rec xto_list i l = match l with | [] -> [] - | (x, v) :: l' -> - if i = x then v :: xto_list (i + 1) l' else Q.zero :: xto_list (i + 1) l + | {var = x; coe = v} :: l' -> + if Int.equal i x then v :: xto_list (i + 1) l' + else Q.zero :: xto_list (i + 1) l in xto_list 0 m -let cons i v rst = if v =/ Q.zero then rst else (i, v) :: rst +let cons i v rst = if v =/ Q.zero then rst else {var = i; coe = v} :: rst let rec update i f t = match t with | [] -> cons i (f Q.zero) [] - | (k, v) :: l -> ( - match Int.compare i k with - | 0 -> cons k (f v) l + | x :: l -> ( + match Int.compare i x.var with + | 0 -> cons x.var (f x.coe) l | -1 -> cons i (f Q.zero) t - | 1 -> (k, v) :: update i f l + | 1 -> x :: update i f l | _ -> failwith "compare_num" ) let rec set i n t = match t with | [] -> cons i n [] - | (k, v) :: l -> ( - match Int.compare i k with - | 0 -> cons k n l + | x :: l -> ( + match Int.compare i x.var with + | 0 -> cons x.var n l | -1 -> cons i n t - | 1 -> (k, v) :: set i n l + | 1 -> x :: set i n l | _ -> failwith "compare_num" ) -let cst n = if n =/ Q.zero then [] else [(0, n)] +let cst n = if n =/ Q.zero then [] else [{var = 0; coe = n}] let mul z t = if z =/ Q.zero then [] else if z =/ Q.one then t - else List.map (fun (i, n) -> (i, z */ n)) t + else List.map (fun {var = i; coe = n} -> {var = i; coe = z */ n}) t let div z t = - if z <>/ Q.one then List.map (fun (x, nx) -> (x, nx // z)) t else t + if z <>/ Q.one then + List.map (fun {var = x; coe = nx} -> {var = x; coe = nx // z}) t + else t -let uminus t = List.map (fun (i, n) -> (i, Q.neg n)) t +let uminus t = List.map (fun {var = i; coe = n} -> {var = i; coe = Q.neg n}) t let rec add (ve1 : t) (ve2 : t) = match (ve1, ve2) with | [], v | v, [] -> v - | (v1, c1) :: l1, (v2, c2) :: l2 -> + | {var = v1; coe = c1} :: l1, {var = v2; coe = c2} :: l2 -> let cmp = Int.compare v1 v2 in if cmp == 0 then let s = c1 +/ c2 in - if Q.zero =/ s then add l1 l2 else (v1, s) :: add l1 l2 - else if cmp < 0 then (v1, c1) :: add l1 ve2 - else (v2, c2) :: add l2 ve1 + if Q.zero =/ s then add l1 l2 else {var = v1; coe = s} :: add l1 l2 + else if cmp < 0 then {var = v1; coe = c1} :: add l1 ve2 + else {var = v2; coe = c2} :: add l2 ve1 let rec xmul_add (n1 : Q.t) (ve1 : t) (n2 : Q.t) (ve2 : t) = match (ve1, ve2) with | [], _ -> mul n2 ve2 | _, [] -> mul n1 ve1 - | (v1, c1) :: l1, (v2, c2) :: l2 -> + | {var = v1; coe = c1} :: l1, {var = v2; coe = c2} :: l2 -> let cmp = Int.compare v1 v2 in if cmp == 0 then let s = (n1 */ c1) +/ (n2 */ c2) in if Q.zero =/ s then xmul_add n1 l1 n2 l2 - else (v1, s) :: xmul_add n1 l1 n2 l2 - else if cmp < 0 then (v1, n1 */ c1) :: xmul_add n1 l1 n2 ve2 - else (v2, n2 */ c2) :: xmul_add n1 ve1 n2 l2 + else {var = v1; coe = s} :: xmul_add n1 l1 n2 l2 + else if cmp < 0 then {var = v1; coe = n1 */ c1} :: xmul_add n1 l1 n2 ve2 + else {var = v2; coe = n2 */ c2} :: xmul_add n1 ve1 n2 l2 let mul_add n1 ve1 n2 ve2 = if n1 =/ Q.one && n2 =/ Q.one then add ve1 ve2 else xmul_add n1 ve1 n2 ve2 @@ -157,8 +165,7 @@ let mul_add n1 ve1 n2 ve2 = let compare : t -> t -> int = Mutils.Cmp.compare_list (fun x y -> Mutils.Cmp.compare_lexical - [ (fun () -> Int.compare (fst x) (fst y)) - ; (fun () -> Q.compare (snd x) (snd y)) ]) + [(fun () -> Int.compare x.var y.var); (fun () -> Q.compare x.coe y.coe)]) (** [tail v vect] returns - [None] if [v] is not a variable of the vector [vect] @@ -169,7 +176,7 @@ let compare : t -> t -> int = let rec tail (v : var) (vect : t) = match vect with | [] -> None - | (v', vl) :: vect' -> ( + | {var = v'; coe = vl} :: vect' -> ( match Int.compare v' v with | 0 -> Some (vl, vect) (* Ok, found *) | -1 -> tail v vect' (* Might be in the tail *) @@ -178,38 +185,49 @@ let rec tail (v : var) (vect : t) = (* Hopeless *) let get v vect = match tail v vect with None -> Q.zero | Some (vl, _) -> vl -let is_constant v = match v with [] | [(0, _)] -> true | _ -> false -let get_cst vect = match vect with (0, v) :: _ -> v | _ -> Q.zero -let choose v = match v with [] -> None | (vr, vl) :: rst -> Some (vr, vl, rst) -let rec fresh v = match v with [] -> 1 | [(v, _)] -> v + 1 | _ :: v -> fresh v -let variables v = List.fold_left (fun acc (x, _) -> ISet.add x acc) ISet.empty v -let decomp_cst v = match v with (0, vl) :: v -> (vl, v) | _ -> (Q.zero, v) +let is_constant v = match v with [] | [{var = 0}] -> true | _ -> false +let get_cst vect = match vect with {var = 0; coe = v} :: _ -> v | _ -> Q.zero + +let choose v = + match v with [] -> None | {var = vr; coe = vl} :: rst -> Some (vr, vl, rst) + +let rec fresh v = + match v with [] -> 1 | [{var = v}] -> v + 1 | _ :: v -> fresh v + +let variables v = + List.fold_left (fun acc {var = x} -> ISet.add x acc) ISet.empty v + +let decomp_cst v = + match v with {var = 0; coe = vl} :: v -> (vl, v) | _ -> (Q.zero, v) let rec decomp_at i v = match v with | [] -> (Q.zero, null) - | (vr, vl) :: r -> - if i = vr then (vl, r) else if i < vr then (Q.zero, v) else decomp_at i r + | {var = vr; coe = vl} :: r -> + if Int.equal i vr then (vl, r) + else if i < vr then (Q.zero, v) + else decomp_at i r -let decomp_fst v = match v with [] -> ((0, Q.zero), []) | x :: v -> (x, v) +let decomp_fst v = + match v with [] -> ((0, Q.zero), []) | x :: v -> ((x.var, x.coe), v) let rec subst (vr : int) (e : t) (v : t) = match v with | [] -> [] - | (x, n) :: v' -> ( + | {var = x; coe = n} :: v' -> ( match Int.compare vr x with | 0 -> mul_add n e Q.one v' | -1 -> v - | 1 -> add [(x, n)] (subst vr e v') + | 1 -> add [{var = x; coe = n}] (subst vr e v') | _ -> assert false ) -let fold f acc v = List.fold_left (fun acc (v, i) -> f acc v i) acc v +let fold f acc v = List.fold_left (fun acc x -> f acc x.var x.coe) acc v let fold_error f acc v = let rec fold acc v = match v with | [] -> Some acc - | (x, i) :: v' -> ( + | {var = x; coe = i} :: v' -> ( match f acc x i with None -> None | Some acc' -> fold acc' v' ) in fold acc v @@ -217,11 +235,12 @@ let fold_error f acc v = let rec find p v = match v with | [] -> None - | (v, n) :: v' -> ( match p v n with None -> find p v' | Some r -> Some r ) + | {var = v; coe = n} :: v' -> ( + match p v n with None -> find p v' | Some r -> Some r ) -let for_all p l = List.for_all (fun (v, n) -> p v n) l -let decr_var i v = List.map (fun (v, n) -> (v - i, n)) v -let incr_var i v = List.map (fun (v, n) -> (v + i, n)) v +let for_all p l = List.for_all (fun {var = v; coe = n} -> p v n) l +let decr_var i v = List.map (fun x -> {x with var = x.var - i}) v +let incr_var i v = List.map (fun x -> {x with var = x.var + i}) v let gcd v = let res = @@ -239,12 +258,15 @@ let normalise v = let gcd = fold (fun c _ n -> Z.gcd c (Q.num n)) Z.zero v in if Int.equal (Z.compare gcd Z.zero) 0 then Z.one else gcd in - List.map (fun (x, v) -> (x, v */ Q.of_bigint ppcm // Q.of_bigint gcd)) v + List.map + (fun {var = x; coe = v} -> + {var = x; coe = v */ Q.of_bigint ppcm // Q.of_bigint gcd}) + v let rec exists2 p vect1 vect2 = match (vect1, vect2) with | _, [] | [], _ -> None - | (v1, n1) :: vect1', (v2, n2) :: vect2' -> + | {var = v1; coe = n1} :: vect1', {var = v2; coe = n2} :: vect2' -> if Int.equal v1 v2 then if p n1 n2 then Some (v1, n1, n2) else exists2 p vect1' vect2' else if v1 < v2 then exists2 p vect1' vect2 @@ -254,26 +276,26 @@ let dotproduct v1 v2 = let rec dot acc v1 v2 = match (v1, v2) with | [], _ | _, [] -> acc - | (x1, n1) :: v1', (x2, n2) :: v2' -> - if x1 == x2 then dot (acc +/ (n1 */ n2)) v1' v2' + | {var = x1; coe = n1} :: v1', {var = x2; coe = n2} :: v2' -> + if Int.equal x1 x2 then dot (acc +/ (n1 */ n2)) v1' v2' else if x1 < x2 then dot acc v1' v2 else dot acc v1 v2' in dot Q.zero v1 v2 -let map f v = List.map (fun (x, v) -> f x v) v +let map f v = List.map (fun {var = x; coe = v} -> f x v) v let abs_min_elt v = match v with | [] -> None - | (v, vl) :: r -> + | {var = v; coe = vl} :: r -> Some (List.fold_left - (fun (v1, vl1) (v2, vl2) -> + (fun (v1, vl1) {var = v2; coe = vl2} -> if Q.abs vl1 </ Q.abs vl2 then (v1, vl1) else (v2, vl2)) (v, vl) r) -let partition p = List.partition (fun (vr, vl) -> p vr vl) +let partition p = List.partition (fun {var = vr; coe = vl} -> p vr vl) let mkvar x = set x Q.one null module Bound = struct @@ -281,7 +303,9 @@ module Bound = struct let of_vect (v : vector) = match v with - | [(x, v)] -> if x = 0 then None else Some {cst = Q.zero; var = x; coeff = v} - | [(0, v); (x, v')] -> Some {cst = v; var = x; coeff = v'} + | [{var = x; coe = v}] -> + if Int.equal x 0 then None else Some {cst = Q.zero; var = x; coeff = v} + | [{var = 0; coe = v}; {var = x; coe = v'}] -> + Some {cst = v; var = x; coeff = v'} | _ -> None end diff --git a/plugins/micromega/vect.mli b/plugins/micromega/vect.mli index 8a26337602..9db6c075f8 100644 --- a/plugins/micromega/vect.mli +++ b/plugins/micromega/vect.mli @@ -11,10 +11,9 @@ open NumCompat open Mutils -type var = int (** Variables are simply (positive) integers. *) +type var = int -type t (** The type of vectors or equivalently linear expressions. The current implementation is using association lists. A list [(0,c),(x1,ai),...,(xn,an)] represents the linear expression @@ -24,6 +23,7 @@ type t Moreover, the representation is spare and variables with a zero coefficient are not represented. *) +type t type vector = t @@ -38,147 +38,147 @@ val compare : t -> t -> int (** {1 Basic accessors and utility functions} *) -val pp_gen : (out_channel -> var -> unit) -> out_channel -> t -> unit (** [pp_gen pp_var o v] prints the representation of the vector [v] over the channel [o] *) +val pp_gen : (out_channel -> var -> unit) -> out_channel -> t -> unit -val pp : out_channel -> t -> unit (** [pp o v] prints the representation of the vector [v] over the channel [o] *) +val pp : out_channel -> t -> unit -val pp_smt : out_channel -> t -> unit (** [pp_smt o v] prints the representation of the vector [v] over the channel [o] using SMTLIB conventions *) +val pp_smt : out_channel -> t -> unit -val variables : t -> ISet.t (** [variables v] returns the set of variables with non-zero coefficients *) +val variables : t -> ISet.t -val get_cst : t -> Q.t (** [get_cst v] returns c i.e. the coefficient of the variable zero *) +val get_cst : t -> Q.t -val decomp_cst : t -> Q.t * t (** [decomp_cst v] returns the pair (c,a1.x1+...+an.xn) *) +val decomp_cst : t -> Q.t * t -val decomp_at : int -> t -> Q.t * t (** [decomp_cst v] returns the pair (ai, ai+1.xi+...+an.xn) *) +val decomp_at : int -> t -> Q.t * t val decomp_fst : t -> (var * Q.t) * t -val cst : Q.t -> t (** [cst c] returns the vector v=c+0.x1+...+0.xn *) +val cst : Q.t -> t -val is_constant : t -> bool (** [is_constant v] holds if [v] is a constant vector i.e. v=c+0.x1+...+0.xn *) +val is_constant : t -> bool -val null : t (** [null] is the empty vector i.e. 0+0.x1+...+0.xn *) +val null : t -val is_null : t -> bool (** [is_null v] returns whether [v] is the [null] vector i.e [equal v null] *) +val is_null : t -> bool -val get : var -> t -> Q.t (** [get xi v] returns the coefficient ai of the variable [xi]. [get] is also defined for the variable 0 *) +val get : var -> t -> Q.t -val set : var -> Q.t -> t -> t (** [set xi ai' v] returns the vector c+a1.x1+...ai'.xi+...+an.xn i.e. the coefficient of the variable xi is set to ai' *) +val set : var -> Q.t -> t -> t -val mkvar : var -> t (** [mkvar xi] returns 1.xi *) +val mkvar : var -> t -val update : var -> (Q.t -> Q.t) -> t -> t (** [update xi f v] returns c+a1.x1+...+f(ai).xi+...+an.xn *) +val update : var -> (Q.t -> Q.t) -> t -> t -val fresh : t -> int (** [fresh v] return the fresh variable with index 1+ max (variables v) *) +val fresh : t -> int -val choose : t -> (var * Q.t * t) option (** [choose v] decomposes a vector [v] depending on whether it is [null] or not. @return None if v is [null] @return Some(x,n,r) where v = r + n.x x is the smallest variable with non-zero coefficient n <> 0. *) +val choose : t -> (var * Q.t * t) option -val from_list : Q.t list -> t (** [from_list l] returns the vector c+a1.x1...an.xn from the list of coefficient [l=c;a1;...;an] *) +val from_list : Q.t list -> t -val to_list : t -> Q.t list (** [to_list v] returns the list of all coefficient of the vector v i.e. [c;a1;...;an] The list representation is (obviously) not sparsed and therefore certain ai may be 0 *) +val to_list : t -> Q.t list -val decr_var : int -> t -> t (** [decr_var i v] decrements the variables of the vector [v] by the amount [i]. Beware, it is only defined if all the variables of v are greater than i *) +val decr_var : int -> t -> t -val incr_var : int -> t -> t (** [incr_var i v] increments the variables of the vector [v] by the amount [i]. *) +val incr_var : int -> t -> t -val gcd : t -> Z.t (** [gcd v] returns gcd(num(c),num(a1),...,num(an)) where num extracts the numerator of a rational value. *) +val gcd : t -> Z.t -val normalise : t -> t (** [normalise v] returns a vector with only integer coefficients *) +val normalise : t -> t (** {1 Linear arithmetics} *) -val add : t -> t -> t (** [add v1 v2] is vector addition. @param v1 is of the form c +a1.x1 +...+an.xn @param v2 is of the form c'+a1'.x1 +...+an'.xn @return c1+c1'+ (a1+a1').x1 + ... + (an+an').xn *) +val add : t -> t -> t -val mul : Q.t -> t -> t (** [mul a v] is vector multiplication of vector [v] by a scalar [a]. @return a.v = a.c+a.a1.x1+...+a.an.xn *) +val mul : Q.t -> t -> t -val mul_add : Q.t -> t -> Q.t -> t -> t (** [mul_add c1 v1 c2 v2] returns the linear combination c1.v1+c2.v2 *) +val mul_add : Q.t -> t -> Q.t -> t -> t -val subst : int -> t -> t -> t (** [subst x v v'] replaces x by v in vector v' *) +val subst : int -> t -> t -> t -val div : Q.t -> t -> t (** [div c1 v1] returns the mutiplication by the inverse of c1 i.e (1/c1).v1 *) +val div : Q.t -> t -> t -val uminus : t -> t (** [uminus v] @return -v the opposite vector of v i.e. (-1).v *) +val uminus : t -> t (** {1 Iterators} *) -val fold : ('acc -> var -> Q.t -> 'acc) -> 'acc -> t -> 'acc (** [fold f acc v] returns f (f (f acc 0 c ) x1 a1 ) ... xn an *) +val fold : ('acc -> var -> Q.t -> 'acc) -> 'acc -> t -> 'acc -val fold_error : ('acc -> var -> Q.t -> 'acc option) -> 'acc -> t -> 'acc option (** [fold_error f acc v] is the same as [fold (fun acc x i -> match acc with None -> None | Some acc' -> f acc' x i) (Some acc) v] but with early exit... *) +val fold_error : ('acc -> var -> Q.t -> 'acc option) -> 'acc -> t -> 'acc option -val find : (var -> Q.t -> 'c option) -> t -> 'c option (** [find f v] returns the first [f xi ai] such that [f xi ai <> None]. If no such xi ai exists, it returns None *) +val find : (var -> Q.t -> 'c option) -> t -> 'c option -val for_all : (var -> Q.t -> bool) -> t -> bool (** [for_all p v] returns /\_{i>=0} (f xi ai) *) +val for_all : (var -> Q.t -> bool) -> t -> bool -val exists2 : (Q.t -> Q.t -> bool) -> t -> t -> (var * Q.t * Q.t) option (** [exists2 p v v'] returns Some(xi,ai,ai') if p(xi,ai,ai') holds and ai,ai' <> 0. It returns None if no such pair of coefficient exists. *) +val exists2 : (Q.t -> Q.t -> bool) -> t -> t -> (var * Q.t * Q.t) option -val dotproduct : t -> t -> Q.t (** [dotproduct v1 v2] is the dot product of v1 and v2. *) +val dotproduct : t -> t -> Q.t val map : (var -> Q.t -> 'a) -> t -> 'a list val abs_min_elt : t -> (var * Q.t) option val partition : (var -> Q.t -> bool) -> t -> t * t module Bound : sig - type t = {cst : Q.t; var : var; coeff : Q.t} (** represents a0 + ai.xi *) + type t = {cst : Q.t; var : var; coeff : Q.t} val of_vect : vector -> t option end diff --git a/plugins/micromega/zify.ml b/plugins/micromega/zify.ml index 53a58342d2..41579d5792 100644 --- a/plugins/micromega/zify.ml +++ b/plugins/micromega/zify.ml @@ -326,20 +326,20 @@ type term_kind = Application of EConstr.constr | OtherTerm of EConstr.constr module type Elt = sig type elt - val name : string (** name *) + val name : string val table : (term_kind * decl_kind) HConstr.t ref val cast : elt decl -> decl_kind val dest : decl_kind -> elt decl option - val get_key : int (** [get_key] is the type-index used as key for the instance *) + val get_key : int - val mk_elt : Evd.evar_map -> EConstr.t -> EConstr.t array -> elt (** [mk_elt evd i [a0,..,an] returns the element of the table built from the type-instance i and the arguments (type indexes and projections) of the type-class constructor. *) + val mk_elt : Evd.evar_map -> EConstr.t -> EConstr.t array -> elt (* val arity : int*) end diff --git a/plugins/ssr/ssrparser.mlg b/plugins/ssr/ssrparser.mlg index 1dca8fd57b..442b40221b 100644 --- a/plugins/ssr/ssrparser.mlg +++ b/plugins/ssr/ssrparser.mlg @@ -350,8 +350,8 @@ let interp_index ist gl idx = | Some c -> let rc = Detyping.detype Detyping.Now false Id.Set.empty (pf_env gl) (project gl) c in begin match Notation.uninterp_prim_token rc with - | _, Constrexpr.Numeral (b,{NumTok.int = s; frac = ""; exp = ""}) -> - let n = int_of_string s in (match b with SPlus -> n | SMinus -> -n) + | _, Constrexpr.Numeral n when NumTok.Signed.is_int n -> + int_of_string (NumTok.Signed.to_string n) | _ -> raise Not_found end | None -> raise Not_found diff --git a/plugins/ssr/ssrvernac.mlg b/plugins/ssr/ssrvernac.mlg index df6189f212..4b78e64d98 100644 --- a/plugins/ssr/ssrvernac.mlg +++ b/plugins/ssr/ssrvernac.mlg @@ -402,7 +402,7 @@ let rec interp_search_about args accu = match args with | [] -> accu | (flag, arg) :: rem -> fun gr env typ -> - let ans = Search.search_about_filter arg gr env typ in + let ans = Search.search_filter arg gr env typ in (if flag then ans else not ans) && interp_search_about rem accu gr env typ let interp_search_arg arg = diff --git a/plugins/syntax/float_syntax.ml b/plugins/syntax/float_syntax.ml index 23d4d63228..e0a9906689 100644 --- a/plugins/syntax/float_syntax.ml +++ b/plugins/syntax/float_syntax.ml @@ -22,9 +22,56 @@ let make_path dir id = Libnames.make_path (make_dir dir) (Id.of_string id) (*** Parsing for float in digital notation ***) -let interp_float ?loc (sign,n) = - let sign = Constrexpr.(match sign with SPlus -> "" | SMinus -> "-") in - DAst.make ?loc (GFloat (Float64.of_string (sign ^ NumTok.to_string n))) +let warn_inexact_float = + CWarnings.create ~name:"inexact-float" ~category:"parsing" + (fun (sn, f) -> + Pp.strbrk + (Printf.sprintf + "The constant %s is not a binary64 floating-point value. \ + A closest value will be used and unambiguously printed %s." + sn (Float64.to_string f))) + +let interp_float ?loc n = + let sn = NumTok.Signed.to_string n in + let f = Float64.of_string sn in + (* return true when f is not exactly equal to n, + this is only used to decide whether or not to display a warning + and does not play any actual role in the parsing *) + let inexact () = match Float64.classify f with + | Float64.(PInf | NInf | NaN) -> true + | Float64.(PZero | NZero) -> not (NumTok.Signed.is_zero n) + | Float64.(PNormal | NNormal | PSubn | NSubn) -> + let m, e = + let (_, i), f, e = NumTok.Signed.to_decimal_and_exponent n in + let i = NumTok.UnsignedNat.to_string i in + let f = match f with + | None -> "" | Some f -> NumTok.UnsignedNat.to_string f in + let e = match e with + | None -> "0" | Some e -> NumTok.SignedNat.to_string e in + Bigint.of_string (i ^ f), + (try int_of_string e with Failure _ -> 0) - String.length f in + let m', e' = + let m', e' = Float64.frshiftexp f in + let m' = Float64.normfr_mantissa m' in + let e' = Uint63.to_int_min e' 4096 - Float64.eshift - 53 in + Bigint.of_string (Uint63.to_string m'), + e' in + let c2, c5 = Bigint.(of_int 2, of_int 5) in + (* check m*5^e <> m'*2^e' *) + let check m e m' e' = + not (Bigint.(equal (mult m (pow c5 e)) (mult m' (pow c2 e')))) in + (* check m*5^e*2^e' <> m' *) + let check' m e e' m' = + not (Bigint.(equal (mult (mult m (pow c5 e)) (pow c2 e')) m')) in + (* we now have to check m*10^e <> m'*2^e' *) + if e >= 0 then + if e <= e' then check m e m' (e' - e) + else check' m e (e - e') m' + else (* e < 0 *) + if e' <= e then check m' (-e) m (e - e') + else check' m' (-e) (e' - e) m in + if inexact () then warn_inexact_float ?loc (sn, f); + DAst.make ?loc (GFloat f) (* Pretty printing is already handled in constrextern.ml *) diff --git a/plugins/syntax/g_numeral.mlg b/plugins/syntax/g_numeral.mlg index 49d29e7b63..e66dbe17b2 100644 --- a/plugins/syntax/g_numeral.mlg +++ b/plugins/syntax/g_numeral.mlg @@ -21,16 +21,16 @@ open Pcoq.Prim let pr_numnot_option = function | Nop -> mt () - | Warning n -> str "(warning after " ++ str n ++ str ")" - | Abstract n -> str "(abstract after " ++ str n ++ str ")" + | Warning n -> str "(warning after " ++ NumTok.UnsignedNat.print n ++ str ")" + | Abstract n -> str "(abstract after " ++ NumTok.UnsignedNat.print n ++ str ")" } VERNAC ARGUMENT EXTEND numnotoption PRINTED BY { pr_numnot_option } | [ ] -> { Nop } -| [ "(" "warning" "after" bigint(waft) ")" ] -> { Warning waft } -| [ "(" "abstract" "after" bigint(n) ")" ] -> { Abstract n } +| [ "(" "warning" "after" bignat(waft) ")" ] -> { Warning (NumTok.UnsignedNat.of_string waft) } +| [ "(" "abstract" "after" bignat(n) ")" ] -> { Abstract (NumTok.UnsignedNat.of_string n) } END VERNAC COMMAND EXTEND NumeralNotation CLASSIFIED AS SIDEFF diff --git a/plugins/syntax/r_syntax.ml b/plugins/syntax/r_syntax.ml index 7043653f7b..c4e9c8b73d 100644 --- a/plugins/syntax/r_syntax.ml +++ b/plugins/syntax/r_syntax.ml @@ -12,7 +12,6 @@ open Util open Names open Glob_term open Bigint -open Constrexpr (* Poor's man DECLARE PLUGIN *) let __coq_plugin_name = "r_syntax_plugin" @@ -113,8 +112,8 @@ let z_modpath = MPdot (MPfile (make_dir binintdef), Label.make "Z") let glob_pow_pos = GlobRef.ConstRef (Constant.make2 z_modpath @@ Label.make "pow_pos") -let r_of_rawnum ?loc (sign,n) = - let n, f, e = NumTok.(n.int, n.frac, n.exp) in +let r_of_rawnum ?loc n = + let n,e = NumTok.Signed.to_bigint_and_exponent n in let izr z = DAst.make @@ GApp (DAst.make @@ GRef(glob_IZR,None), [z]) in let rmult r r' = @@ -126,15 +125,7 @@ let r_of_rawnum ?loc (sign,n) = let e = pos_of_bignat e in DAst.make @@ GApp (DAst.make @@ GRef(glob_pow_pos,None), [ten; e]) in let n = - let n = Bigint.of_string (n ^ f) in - let n = match sign with SPlus -> n | SMinus -> Bigint.(neg n) in izr (z_of_int ?loc n) in - let e = - let e = if e = "" then Bigint.zero else match e.[1] with - | '+' -> Bigint.of_string (String.sub e 2 (String.length e - 2)) - | '-' -> Bigint.(neg (of_string (String.sub e 2 (String.length e - 2)))) - | _ -> Bigint.of_string (String.sub e 1 (String.length e - 1)) in - Bigint.(sub e (of_int (String.length (String.concat "" (String.split_on_char '_' f))))) in if Bigint.is_strictly_pos e then rmult n (izr (pow10 e)) else if Bigint.is_strictly_neg e then rdiv n (izr (pow10 (neg e))) else n (* e = 0 *) @@ -143,12 +134,41 @@ let r_of_rawnum ?loc (sign,n) = (* Printing R via scopes *) (**********************************************************************) -let rawnum_of_r c = match DAst.get c with +let rawnum_of_r c = + (* print i * 10^e, precondition: e <> 0 *) + let numTok_of_int_exp i e = + (* choose between 123e-2 and 1.23, this is purely heuristic + and doesn't play any soundness role *) + let choose_exponent = + if Bigint.is_strictly_pos e then + true (* don't print 12 * 10^2 as 1200 to distinguish them *) + else + let i = Bigint.to_string i in + let li = if i.[0] = '-' then String.length i - 1 else String.length i in + let e = Bigint.neg e in + let le = String.length (Bigint.to_string e) in + Bigint.(less_than (add (of_int li) (of_int le)) e) in + (* print 123 * 10^-2 as 123e-2 *) + let numTok_exponent () = NumTok.Signed.of_bigint_and_exponent i e in + (* print 123 * 10^-2 as 1.23, precondition e < 0 *) + let numTok_dot () = + let s, i = + if Bigint.is_pos_or_zero i then NumTok.SPlus, Bigint.to_string i + else NumTok.SMinus, Bigint.(to_string (neg i)) in + let ni = String.length i in + let e = - (Bigint.to_int e) in + assert (e > 0); + let i, f = + if e < ni then String.sub i 0 (ni - e), String.sub i (ni - e) e + else "0", String.make (e - ni) '0' ^ i in + let i = s, NumTok.UnsignedNat.of_string i in + let f = NumTok.UnsignedNat.of_string f in + NumTok.Signed.of_decimal_and_exponent i (Some f) None in + if choose_exponent then numTok_exponent () else numTok_dot () in + match DAst.get c with | GApp (r, [a]) when is_gr r glob_IZR -> let n = bigint_of_z a in - let s, n = - if is_strictly_neg n then SMinus, neg n else SPlus, n in - s, NumTok.int (to_string n) + NumTok.Signed.of_bigint n | GApp (md, [l; r]) when is_gr md glob_Rmult || is_gr md glob_Rdiv -> begin match DAst.get l, DAst.get r with | GApp (i, [l]), GApp (i', [r]) @@ -161,11 +181,8 @@ let rawnum_of_r c = match DAst.get c with else let i = bigint_of_z l in let e = bignat_of_pos e in - let s, i = if is_pos_or_zero i then SPlus, i else SMinus, neg i in - let i = Bigint.to_string i in - let se = if is_gr md glob_Rdiv then "-" else "" in - let e = "e" ^ se ^ Bigint.to_string e in - s, { NumTok.int = i; frac = ""; exp = e } + let e = if is_gr md glob_Rdiv then neg e else e in + numTok_of_int_exp i e | _ -> raise Non_closed_number end | _ -> raise Non_closed_number diff --git a/pretyping/coercionops.ml b/pretyping/coercionops.ml index d6458e1409..49401a9937 100644 --- a/pretyping/coercionops.ml +++ b/pretyping/coercionops.ml @@ -67,8 +67,6 @@ end module ClTypMap = Map.Make(ClTyp) -module IntMap = Map.Make(Int) - let cl_typ_eq t1 t2 = Int.equal (cl_typ_ord t1 t2) 0 type inheritance_path = coe_info_typ list @@ -97,13 +95,13 @@ struct module Index = struct include Int let print = Pp.int end - type 'a t = { v : (cl_typ * 'a) IntMap.t; s : int; inv : int ClTypMap.t } - let empty = { v = IntMap.empty; s = 0; inv = ClTypMap.empty } + type 'a t = { v : (cl_typ * 'a) Int.Map.t; s : int; inv : int ClTypMap.t } + let empty = { v = Int.Map.empty; s = 0; inv = ClTypMap.empty } let mem y b = ClTypMap.mem y b.inv - let map x b = IntMap.find x b.v - let revmap y b = let n = ClTypMap.find y b.inv in (n, snd (IntMap.find n b.v)) + let map x b = Int.Map.find x b.v + let revmap y b = let n = ClTypMap.find y b.inv in (n, snd (Int.Map.find n b.v)) let add x y b = - { v = IntMap.add b.s (x,y) b.v; s = b.s+1; inv = ClTypMap.add x b.s b.inv } + { v = Int.Map.add b.s (x,y) b.v; s = b.s+1; inv = ClTypMap.add x b.s b.inv } let dom b = List.rev (ClTypMap.fold (fun x _ acc -> x::acc) b.inv []) end diff --git a/pretyping/indrec.ml b/pretyping/indrec.ml index c92c9a75a0..b5d81f762a 100644 --- a/pretyping/indrec.ml +++ b/pretyping/indrec.ml @@ -530,22 +530,25 @@ let change_sort_arity sort = corresponding eta-expanded term *) let weaken_sort_scheme env evd set sort npars term ty = let evdref = ref evd in - let rec drec np elim = + let rec drec ctx np elim = match kind elim with | Prod (n,t,c) -> + let ctx = LocalAssum (n, t) :: ctx in if Int.equal np 0 then let osort, t' = change_sort_arity sort t in evdref := (if set then Evd.set_eq_sort else Evd.set_leq_sort) env !evdref sort osort; mkProd (n, t', c), - mkLambda (n, t', mkApp(term,Termops.rel_vect 0 (npars+1))) + mkLambda (n, t', mkApp(term, Context.Rel.to_extended_vect mkRel 0 ctx)) else - let c',term' = drec (np-1) c in + let c',term' = drec ctx (np-1) c in mkProd (n, t, c'), mkLambda (n, t, term') - | LetIn (n,b,t,c) -> let c',term' = drec np c in - mkLetIn (n,b,t,c'), mkLetIn (n,b,t,term') + | LetIn (n,b,t,c) -> + let ctx = LocalDef (n, b, t) :: ctx in + let c',term' = drec ctx np c in + mkLetIn (n,b,t,c'), mkLetIn (n,b,t,term') | _ -> anomaly ~label:"weaken_sort_scheme" (Pp.str "wrong elimination type.") in - let ty, term = drec npars ty in + let ty, term = drec [] npars ty in !evdref, ty, term (**********************************************************************) diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index 4bab3bd6ea..52122c09df 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -187,7 +187,7 @@ let interp_sort_info ?loc evd l = in (evd', Univ.sup u u')) (evd, Univ.Universe.type0m) l -type inference_hook = env -> evar_map -> Evar.t -> evar_map * constr +type inference_hook = env -> evar_map -> Evar.t -> (evar_map * constr) option type inference_flags = { use_typeclasses : bool; @@ -231,7 +231,7 @@ let frozen_and_pending_holes (sigma, sigma') = end in FrozenProgress data -let apply_typeclasses ~program_mode env sigma frozen fail_evar = +let apply_typeclasses ~program_mode ~fail_evar env sigma frozen = let filter_frozen = match frozen with | FrozenId map -> fun evk -> Evar.Map.mem evk map | FrozenProgress (lazy (frozen, _)) -> fun evk -> Evar.Set.mem evk frozen @@ -247,17 +247,16 @@ let apply_typeclasses ~program_mode env sigma frozen fail_evar = else sigma in sigma -let apply_inference_hook hook env sigma frozen = match frozen with +let apply_inference_hook (hook : inference_hook) env sigma frozen = match frozen with | FrozenId _ -> sigma | FrozenProgress (lazy (_, pending)) -> Evar.Set.fold (fun evk sigma -> if Evd.is_undefined sigma evk (* in particular not defined by side-effect *) then - try - let sigma, c = hook env sigma evk in + match hook env sigma evk with + | Some (sigma, c) -> Evd.define evk c sigma - with Exit -> - sigma + | None -> sigma else sigma) pending sigma @@ -271,7 +270,7 @@ let apply_heuristics env sigma fail_evar = let check_typeclasses_instances_are_solved ~program_mode env current_sigma frozen = (* Naive way, call resolution again with failure flag *) - apply_typeclasses ~program_mode env current_sigma frozen true + apply_typeclasses ~program_mode ~fail_evar:true env current_sigma frozen let check_extra_evars_are_solved env current_sigma frozen = match frozen with | FrozenId _ -> () @@ -314,7 +313,7 @@ let solve_remaining_evars ?hook flags env ?initial sigma = let frozen = frozen_and_pending_holes (initial, sigma) in let sigma = if flags.use_typeclasses - then apply_typeclasses ~program_mode env sigma frozen false + then apply_typeclasses ~fail_evar:false ~program_mode env sigma frozen else sigma in let sigma = match hook with diff --git a/pretyping/pretyping.mli b/pretyping/pretyping.mli index 700ca93c33..abbb745161 100644 --- a/pretyping/pretyping.mli +++ b/pretyping/pretyping.mli @@ -44,8 +44,6 @@ type typing_constraint = | OfType of types (** A term of the expected type *) | WithoutTypeConstraint (** A term of unknown expected type *) -type inference_hook = env -> evar_map -> Evar.t -> evar_map * constr - type inference_flags = { use_typeclasses : bool; solve_unification_constraints : bool; @@ -103,13 +101,17 @@ val understand_ltac : inference_flags -> val understand : ?flags:inference_flags -> ?expected_type:typing_constraint -> env -> evar_map -> glob_constr -> constr Evd.in_evar_universe_context +(** [hook env sigma ev] returns [Some (sigma', term)] if [ev] can be + instantiated with a solution, [None] otherwise. Used to extend + [solve_remaining_evars] below. *) +type inference_hook = env -> evar_map -> Evar.t -> (evar_map * constr) option + (** Trying to solve remaining evars and remaining conversion problems possibly using type classes, heuristics, external tactic solver hook depending on given flags. *) (* For simplicity, it is assumed that current map has no other evars with candidate and no other conversion problems that the one in [pending], however, it can contain more evars than the pending ones. *) - val solve_remaining_evars : ?hook:inference_hook -> inference_flags -> env -> ?initial:evar_map -> (* current map *) evar_map -> evar_map diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml index 1e4b537117..8822cc2338 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -622,9 +622,8 @@ type stack_reduction_function = contextual_stack_reduction_function type local_stack_reduction_function = evar_map -> constr -> constr * constr list -type contextual_state_reduction_function = +type state_reduction_function = env -> evar_map -> state -> state -type state_reduction_function = contextual_state_reduction_function type local_state_reduction_function = evar_map -> state -> state let pr_state env sigma (tm,sk) = @@ -1571,10 +1570,6 @@ let vm_infer_conv ?(pb=Reduction.CUMUL) env t1 t2 = (* Special-Purpose Reduction *) (********************************************************************) -let whd_meta sigma c = match EConstr.kind sigma c with - | Meta p -> (try meta_value sigma p with Not_found -> c) - | _ -> c - let default_plain_instance_ident = Id.of_string "H" (* Try to replace all metas. Does not replace metas in the metas' values @@ -1810,70 +1805,3 @@ let meta_instance sigma b = let nf_meta sigma c = let cl = mk_freelisted c in meta_instance sigma { cl with rebus = cl.rebus } - -(* Instantiate metas that create beta/iota redexes *) - -let meta_reducible_instance evd b = - let fm = b.freemetas in - let fold mv accu = - let fvalue = try meta_opt_fvalue evd mv with Not_found -> None in - match fvalue with - | None -> accu - | Some (g, (_, s)) -> Metamap.add mv (g.rebus, s) accu - in - let metas = Metaset.fold fold fm Metamap.empty in - let rec irec u = - let u = whd_betaiota Evd.empty u (* FIXME *) in - match EConstr.kind evd u with - | Case (ci,p,c,bl) when EConstr.isMeta evd (strip_outer_cast evd c) -> - let m = destMeta evd (strip_outer_cast evd c) in - (match - try - let g, s = Metamap.find m metas in - let is_coerce = match s with CoerceToType -> true | _ -> false in - if isConstruct evd g || not is_coerce then Some g else None - with Not_found -> None - with - | Some g -> irec (mkCase (ci,p,g,bl)) - | None -> mkCase (ci,irec p,c,Array.map irec bl)) - | App (f,l) when EConstr.isMeta evd (strip_outer_cast evd f) -> - let m = destMeta evd (strip_outer_cast evd f) in - (match - try - let g, s = Metamap.find m metas in - let is_coerce = match s with CoerceToType -> true | _ -> false in - if isLambda evd g || not is_coerce then Some g else None - with Not_found -> None - with - | Some g -> irec (mkApp (g,l)) - | None -> mkApp (f,Array.map irec l)) - | Meta m -> - (try let g, s = Metamap.find m metas in - let is_coerce = match s with CoerceToType -> true | _ -> false in - if not is_coerce then irec g else u - with Not_found -> u) - | Proj (p,c) when isMeta evd c || isCast evd c && isMeta evd (pi1 (destCast evd c)) (* What if two nested casts? *) -> - let m = try destMeta evd c with _ -> destMeta evd (pi1 (destCast evd c)) (* idem *) in - (match - try - let g, s = Metamap.find m metas in - let is_coerce = match s with CoerceToType -> true | _ -> false in - if isConstruct evd g || not is_coerce then Some g else None - with Not_found -> None - with - | Some g -> irec (mkProj (p,g)) - | None -> mkProj (p,c)) - | _ -> EConstr.map evd irec u - in - if Metaset.is_empty fm then (* nf_betaiota? *) b.rebus - else irec b.rebus - -let betazetaevar_applist sigma n c l = - let rec stacklam n env t stack = - if Int.equal n 0 then applist (substl env t, stack) else - match EConstr.kind sigma t, stack with - | Lambda(_,_,c), arg::stacktl -> stacklam (n-1) (arg::env) c stacktl - | LetIn(_,b,_,c), _ -> stacklam (n-1) (substl env b::env) c stack - | Evar _, _ -> applist (substl env t, stack) - | _ -> anomaly (Pp.str "Not enough lambda/let's.") in - stacklam n [] c l diff --git a/pretyping/reductionops.mli b/pretyping/reductionops.mli index 5202380a13..243a2745f0 100644 --- a/pretyping/reductionops.mli +++ b/pretyping/reductionops.mli @@ -139,9 +139,8 @@ type stack_reduction_function = contextual_stack_reduction_function type local_stack_reduction_function = evar_map -> constr -> constr * constr list -type contextual_state_reduction_function = +type state_reduction_function = env -> evar_map -> state -> state -type state_reduction_function = contextual_state_reduction_function type local_state_reduction_function = evar_map -> state -> state val pr_state : env -> evar_map -> state -> Pp.t @@ -203,8 +202,8 @@ val whd_nored_state : local_state_reduction_function val whd_beta_state : local_state_reduction_function val whd_betaiota_state : local_state_reduction_function val whd_betaiotazeta_state : local_state_reduction_function -val whd_all_state : contextual_state_reduction_function -val whd_allnolet_state : contextual_state_reduction_function +val whd_all_state : state_reduction_function +val whd_allnolet_state : state_reduction_function val whd_betalet_state : local_state_reduction_function (** {6 Head normal forms } *) @@ -309,13 +308,6 @@ val infer_conv_gen : (conv_pb -> l2r:bool -> evar_map -> TransparentState.t -> ?catch_incon:bool -> ?pb:conv_pb -> ?ts:TransparentState.t -> env -> evar_map -> constr -> constr -> evar_map option -(** {6 Special-Purpose Reduction Functions } *) - -val whd_meta : local_reduction_function -val plain_instance : evar_map -> constr Metamap.t -> constr -> constr -val instance : evar_map -> constr Metamap.t -> constr -> constr -val betazetaevar_applist : evar_map -> int -> constr -> constr list -> constr - (** {6 Heuristic for Conversion with Evar } *) val whd_betaiota_deltazeta_for_iota_state : @@ -324,4 +316,3 @@ val whd_betaiota_deltazeta_for_iota_state : (** {6 Meta-related reduction functions } *) val meta_instance : evar_map -> constr freelisted -> constr val nf_meta : evar_map -> constr -> constr -val meta_reducible_instance : evar_map -> constr freelisted -> constr diff --git a/pretyping/retyping.ml b/pretyping/retyping.ml index d4fa2461b4..1f091c3df8 100644 --- a/pretyping/retyping.ml +++ b/pretyping/retyping.ml @@ -97,6 +97,16 @@ let decomp_sort env sigma t = let destSort sigma s = ESorts.kind sigma (destSort sigma s) +let betazetaevar_applist sigma n c l = + let rec stacklam n env t stack = + if Int.equal n 0 then applist (substl env t, stack) else + match EConstr.kind sigma t, stack with + | Lambda(_,_,c), arg::stacktl -> stacklam (n-1) (arg::env) c stacktl + | LetIn(_,b,_,c), _ -> stacklam (n-1) (substl env b::env) c stack + | Evar _, _ -> applist (substl env t, stack) + | _ -> anomaly (Pp.str "Not enough lambda/let's.") in + stacklam n [] c l + let retype ?(polyprop=true) sigma = let rec type_of env cstr = match EConstr.kind sigma cstr with @@ -273,8 +283,8 @@ let relevance_of_term env sigma c = | Rel n -> let len = Range.length rels in if n <= len then Range.get rels (n - 1) - else Retypeops.relevance_of_rel env (n - len) - | Var x -> Retypeops.relevance_of_var env x + else Relevanceops.relevance_of_rel env (n - len) + | Var x -> Relevanceops.relevance_of_var env x | Sort _ -> Sorts.Relevant | Cast (c, _, _) -> aux rels c | Prod ({binder_relevance=r}, _, codom) -> @@ -284,13 +294,13 @@ let relevance_of_term env sigma c = | LetIn ({binder_relevance=r}, _, _, bdy) -> aux (Range.cons r rels) bdy | App (c, _) -> aux rels c - | Const (c,_) -> Retypeops.relevance_of_constant env c + | Const (c,_) -> Relevanceops.relevance_of_constant env c | Ind _ -> Sorts.Relevant - | Construct (c,_) -> Retypeops.relevance_of_constructor env c + | Construct (c,_) -> Relevanceops.relevance_of_constructor env c | Case (ci, _, _, _) -> ci.ci_relevance | Fix ((_,i),(lna,_,_)) -> (lna.(i)).binder_relevance | CoFix (i,(lna,_,_)) -> (lna.(i)).binder_relevance - | Proj (p, _) -> Retypeops.relevance_of_projection env p + | Proj (p, _) -> Relevanceops.relevance_of_projection env p | Int _ | Float _ -> Sorts.Relevant | Meta _ | Evar _ -> Sorts.Relevant diff --git a/pretyping/unification.ml b/pretyping/unification.ml index ec3fb0758e..90dde01915 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -87,6 +87,12 @@ let occur_meta_or_undefined_evar evd c = | _ -> Constr.iter occrec c in try occrec c; false with Occur | Not_found -> true +let whd_meta sigma c = match EConstr.kind sigma c with + | Meta p -> + (try Evd.meta_value sigma p with Not_found -> c) + (* Not recursive, for some reason *) + | _ -> c + let occur_meta_evd sigma mv c = let rec occrec c = (* Note: evars are not instantiated by terms with metas *) diff --git a/pretyping/vnorm.ml b/pretyping/vnorm.ml index 64068724af..d4da93cc5b 100644 --- a/pretyping/vnorm.ml +++ b/pretyping/vnorm.ml @@ -73,7 +73,7 @@ let type_constructor mind mib u (ctx, typ) params = if Int.equal ndecls 0 then ctyp else let _,ctyp = decompose_prod_n_assum ndecls ctyp in - substl (List.rev (adjust_subst_to_rel_context mib.mind_params_ctxt (Array.to_list params))) + substl (subst_of_rel_context_instance mib.mind_params_ctxt (Array.to_list params)) ctyp diff --git a/printing/ppconstr.ml b/printing/ppconstr.ml index 21b9cd4f1f..b285c0abcc 100644 --- a/printing/ppconstr.ml +++ b/printing/ppconstr.ml @@ -77,8 +77,8 @@ let tag_var = tag Tag.variable | LevelSome -> true let prec_of_prim_token = function - | Numeral (SPlus,_) -> lposint - | Numeral (SMinus,_) -> lnegint + | Numeral (NumTok.SPlus,_) -> lposint + | Numeral (NumTok.SMinus,_) -> lnegint | String _ -> latom let print_hunks n pr pr_patt pr_binders (terms, termlists, binders, binderlists) unps = @@ -222,8 +222,7 @@ let tag_var = tag Tag.variable | t -> str " :" ++ pr_sep_com (fun()->brk(1,4)) (pr ltop) t let pr_prim_token = function - | Numeral (SPlus,n) -> str (NumTok.to_string n) - | Numeral (SMinus,n) -> str ("-"^NumTok.to_string n) + | Numeral n -> NumTok.Signed.print n | String s -> qs s let pr_evar pr id l = diff --git a/printing/proof_diffs.ml b/printing/proof_diffs.ml index fb91ea7b5c..3a6424ba9f 100644 --- a/printing/proof_diffs.ml +++ b/printing/proof_diffs.ml @@ -85,8 +85,6 @@ let log_out_ch = ref stdout let cprintf s = cfprintf !log_out_ch s [@@@ocaml.warning "+32"] -module StringMap = Map.Make(String);; - let tokenize_string s = (* todo: cLexer changes buff as it proceeds. Seems like that should be saved, too. But I don't understand how it's used--it looks like things get appended to it but @@ -98,18 +96,17 @@ let tokenize_string s = else stream_tok ((Tok.extract_string true e) :: acc) str in - let st = CLexer.get_lexer_state () in + let st = CLexer.Lexer.State.get () in try let istr = Stream.of_string s in let lex = CLexer.LexerDiff.tok_func istr in let toks = stream_tok [] (fst lex) in - CLexer.set_lexer_state st; + CLexer.Lexer.State.set st; toks with exn -> - CLexer.set_lexer_state st; + CLexer.Lexer.State.set st; raise (Diff_Failure "Input string is not lexable");; - type hyp_info = { idents: string list; rhs_pp: Pp.t; @@ -124,22 +121,22 @@ type hyp_info = { let diff_hyps o_line_idents o_map n_line_idents n_map = let rv : Pp.t list ref = ref [] in - let is_done ident map = (StringMap.find ident map).done_ in + let is_done ident map = (CString.Map.find ident map).done_ in let exists ident map = - try let _ = StringMap.find ident map in true + try let _ = CString.Map.find ident map in true with Not_found -> false in let contains l ident = try [List.find (fun x -> x = ident) l] with Not_found -> [] in let output old_ids_uo new_ids = (* use the order from the old line in case it's changed in the new *) let old_ids = if old_ids_uo = [] then [] else - let orig = (StringMap.find (List.hd old_ids_uo) o_map).idents in + let orig = (CString.Map.find (List.hd old_ids_uo) o_map).idents in List.concat (List.map (contains orig) old_ids_uo) in let setup ids map = if ids = [] then ("", Pp.mt ()) else let open Pp in - let rhs_pp = (StringMap.find (List.hd ids) map).rhs_pp in + let rhs_pp = (CString.Map.find (List.hd ids) map).rhs_pp in let pp_ids = List.map (fun x -> str x) ids in let hyp_pp = List.fold_left (fun l1 l2 -> l1 ++ str ", " ++ l2) (List.hd pp_ids) (List.tl pp_ids) ++ rhs_pp in (string_of_ppcmds hyp_pp, hyp_pp) @@ -151,11 +148,11 @@ let diff_hyps o_line_idents o_map n_line_idents n_map = let hyp_diffs = diff_str ~tokenize_string o_line n_line in let (has_added, has_removed) = has_changes hyp_diffs in if show_removed () && has_removed then begin - List.iter (fun x -> (StringMap.find x o_map).done_ <- true) old_ids; + List.iter (fun x -> (CString.Map.find x o_map).done_ <- true) old_ids; rv := (add_diff_tags `Removed o_pp hyp_diffs) :: !rv; end; if n_line <> "" then begin - List.iter (fun x -> (StringMap.find x n_map).done_ <- true) new_ids; + List.iter (fun x -> (CString.Map.find x n_map).done_ <- true) new_ids; rv := (add_diff_tags `Added n_pp hyp_diffs) :: !rv end in @@ -166,14 +163,14 @@ let diff_hyps o_line_idents o_map n_line_idents n_map = match dtype with | `Removed -> if dtype = `Removed then begin - let o_idents = (StringMap.find ident o_map).idents in + let o_idents = (CString.Map.find ident o_map).idents in (* only show lines that have all idents removed here; other removed idents appear later *) if show_removed () && not (is_done ident o_map) && List.for_all (fun x -> not (exists x n_map)) o_idents then output (List.rev o_idents) [] end | _ -> begin (* Added or Common case *) - let n_idents = (StringMap.find ident n_map).idents in + let n_idents = (CString.Map.find ident n_map).idents in (* Process a new hyp line, possibly splitting it. Duplicates some of process_ident iteration, but easier to understand this way *) @@ -184,13 +181,13 @@ let diff_hyps o_line_idents o_map n_line_idents n_map = let fst_omap_idents = ref None in let add ids id map = ids := id :: !ids; - (StringMap.find id map).done_ <- true in + (CString.Map.find id map).done_ <- true in (* get identifiers shared by one old and one new line, plus other Added in new and other Removed in old *) let process_split ident3 = if not (is_done ident3 n_map) then begin - let this_omap_idents = try Some (StringMap.find ident3 o_map).idents + let this_omap_idents = try Some (CString.Map.find ident3 o_map).idents with Not_found -> None in if !fst_omap_idents = None then fst_omap_idents := this_omap_idents; @@ -290,7 +287,7 @@ map will contain: concl_pp is the conclusion as a Pp.t *) let goal_info goal sigma = - let map = ref StringMap.empty in + let map = ref CString.Map.empty in let line_idents = ref [] in let build_hyp_info env sigma hyp = let (names, body, ty) = hyp in @@ -308,7 +305,7 @@ let goal_info goal sigma = let rhs_pp = mid ++ str " : " ++ ts in let make_entry () = { idents; rhs_pp; done_ = false } in - List.iter (fun ident -> map := (StringMap.add ident (make_entry ()) !map); ()) idents + List.iter (fun ident -> map := (CString.Map.add ident (make_entry ()) !map); ()) idents in try @@ -339,7 +336,7 @@ let unwrap g_s = let goal = Evd.sig_it g_s in let sigma = Refiner.project g_s in goal_info goal sigma - | None -> ([], StringMap.empty, Pp.mt ()) + | None -> ([], CString.Map.empty, Pp.mt ()) let diff_goal_ide og_s ng nsigma = diff_goal_info (unwrap og_s) (goal_info ng nsigma) @@ -405,7 +402,7 @@ the call to db_goal_map and entering the following: (conj (conj ?Goal0 ?Goal1) ?Goal) <--- goal 4 is still the rightmost goal in the proof *) let match_goals ot nt = - let nevar_to_oevar = ref StringMap.empty in + let nevar_to_oevar = ref CString.Map.empty in (* ogname is "" when there is no difference on the current path. It's set to the old goal's evar name once a rewritten goal is found, at which point the code only searches for the replacing goals @@ -514,7 +511,7 @@ let match_goals ot nt = | CPatVar _, CPatVar _ -> () | CEvar (n,l), CEvar (n2,l2) -> let oevar = if ogname = "" then Id.to_string n else ogname in - nevar_to_oevar := StringMap.add (Id.to_string n2) oevar !nevar_to_oevar; + nevar_to_oevar := CString.Map.add (Id.to_string n2) oevar !nevar_to_oevar; iter2 (fun x x2 -> let (_, g) = x and (_, g2) = x2 in constr_expr ogname g g2) l l2 | CEvar (n,l), nt' -> (* pass down the old goal evar name *) @@ -641,16 +638,16 @@ let make_goal_map_i op np = (* >= 2 removals, >= 1 addition, need to match *) let nevar_to_oevar = match_goals (Some (to_constr op)) (to_constr np) in - let oevar_to_og = ref StringMap.empty in + let oevar_to_og = ref CString.Map.empty in let Proof.{sigma=osigma} = Proof.data op in - List.iter (fun og -> oevar_to_og := StringMap.add (goal_to_evar og osigma) og !oevar_to_og) + List.iter (fun og -> oevar_to_og := CString.Map.add (goal_to_evar og osigma) og !oevar_to_og) (Goal.Set.elements rem_gs); let Proof.{sigma=nsigma} = Proof.data np in let get_og ng = let nevar = goal_to_evar ng nsigma in - let oevar = StringMap.find nevar nevar_to_oevar in - let og = StringMap.find oevar !oevar_to_og in + let oevar = CString.Map.find nevar nevar_to_oevar in + let og = CString.Map.find oevar !oevar_to_og in og in Goal.Set.iter (fun ng -> diff --git a/printing/proof_diffs.mli b/printing/proof_diffs.mli index 83e721d3d5..24b171770a 100644 --- a/printing/proof_diffs.mli +++ b/printing/proof_diffs.mli @@ -83,11 +83,4 @@ type hyp_info = { mutable done_: bool; } -module StringMap : -sig - type +'a t - val empty: hyp_info t - val add : string -> hyp_info -> hyp_info t -> hyp_info t -end - -val diff_hyps : string list list -> hyp_info StringMap.t -> string list list -> hyp_info StringMap.t -> Pp.t list +val diff_hyps : string list list -> hyp_info CString.Map.t -> string list list -> hyp_info CString.Map.t -> Pp.t list diff --git a/proofs/clenv.ml b/proofs/clenv.ml index 83ef91bfd9..37d54a4eea 100644 --- a/proofs/clenv.ml +++ b/proofs/clenv.ml @@ -249,6 +249,63 @@ let clenv_dependent ce = clenv_dependent_gen false ce (******************************************************************) +(* Instantiate metas that create beta/iota redexes *) + +let meta_reducible_instance evd b = + let fm = b.freemetas in + let fold mv accu = + let fvalue = try meta_opt_fvalue evd mv with Not_found -> None in + match fvalue with + | None -> accu + | Some (g, (_, s)) -> Metamap.add mv (g.rebus, s) accu + in + let metas = Metaset.fold fold fm Metamap.empty in + let rec irec u = + let u = whd_betaiota Evd.empty u (* FIXME *) in + match EConstr.kind evd u with + | Case (ci,p,c,bl) when EConstr.isMeta evd (strip_outer_cast evd c) -> + let m = destMeta evd (strip_outer_cast evd c) in + (match + try + let g, s = Metamap.find m metas in + let is_coerce = match s with CoerceToType -> true | _ -> false in + if isConstruct evd g || not is_coerce then Some g else None + with Not_found -> None + with + | Some g -> irec (mkCase (ci,p,g,bl)) + | None -> mkCase (ci,irec p,c,Array.map irec bl)) + | App (f,l) when EConstr.isMeta evd (strip_outer_cast evd f) -> + let m = destMeta evd (strip_outer_cast evd f) in + (match + try + let g, s = Metamap.find m metas in + let is_coerce = match s with CoerceToType -> true | _ -> false in + if isLambda evd g || not is_coerce then Some g else None + with Not_found -> None + with + | Some g -> irec (mkApp (g,l)) + | None -> mkApp (f,Array.map irec l)) + | Meta m -> + (try let g, s = Metamap.find m metas in + let is_coerce = match s with CoerceToType -> true | _ -> false in + if not is_coerce then irec g else u + with Not_found -> u) + | Proj (p,c) when isMeta evd c || isCast evd c && isMeta evd (pi1 (destCast evd c)) (* What if two nested casts? *) -> + let m = try destMeta evd c with _ -> destMeta evd (pi1 (destCast evd c)) (* idem *) in + (match + try + let g, s = Metamap.find m metas in + let is_coerce = match s with CoerceToType -> true | _ -> false in + if isConstruct evd g || not is_coerce then Some g else None + with Not_found -> None + with + | Some g -> irec (mkProj (p,g)) + | None -> mkProj (p,c)) + | _ -> EConstr.map evd irec u + in + if Metaset.is_empty fm then (* nf_betaiota? *) b.rebus + else irec b.rebus + let clenv_unify ?(flags=default_unify_flags ()) cv_pb t1 t2 clenv = { clenv with evd = w_unify ~flags clenv.env clenv.evd cv_pb t1 t2 } diff --git a/proofs/goal.ml b/proofs/goal.ml index ede68e63b9..b1f8fd3e97 100644 --- a/proofs/goal.ml +++ b/proofs/goal.ml @@ -131,4 +131,4 @@ module V82 = struct end -module Set = Set.Make(struct type t = goal let compare = Evar.compare end) +module Set = Evar.Set diff --git a/proofs/tacmach.mli b/proofs/tacmach.mli index 19d4ed91e6..d8f7b7eed8 100644 --- a/proofs/tacmach.mli +++ b/proofs/tacmach.mli @@ -37,6 +37,7 @@ val pf_unsafe_type_of : Goal.goal sigma -> constr -> types [@@ocaml.deprecated "Use [type_of] or retyping according to your needs."] val pf_type_of : Goal.goal sigma -> constr -> evar_map * types val pf_hnf_type_of : Goal.goal sigma -> constr -> types +[@@ocaml.deprecated "This is a no-op now"] val pf_get_hyp : Goal.goal sigma -> Id.t -> named_declaration val pf_get_hyp_typ : Goal.goal sigma -> Id.t -> types @@ -49,22 +50,33 @@ val pf_eapply : (env -> evar_map -> 'a -> evar_map * 'b) -> val pf_reduce : (env -> evar_map -> constr -> constr) -> Goal.goal sigma -> constr -> constr +[@@ocaml.deprecated "Use the version in Tacmach.New"] + val pf_e_reduce : (env -> evar_map -> constr -> evar_map * constr) -> Goal.goal sigma -> constr -> evar_map * constr +[@@ocaml.deprecated "Use the version in Tacmach.New"] val pf_whd_all : Goal.goal sigma -> constr -> constr +[@@ocaml.deprecated "Use the version in Tacmach.New"] val pf_hnf_constr : Goal.goal sigma -> constr -> constr +[@@ocaml.deprecated "Use the version in Tacmach.New"] val pf_nf : Goal.goal sigma -> constr -> constr +[@@ocaml.deprecated "Use the version in Tacmach.New"] val pf_nf_betaiota : Goal.goal sigma -> constr -> constr val pf_reduce_to_quantified_ind : Goal.goal sigma -> types -> (inductive * EInstance.t) * types val pf_reduce_to_atomic_ind : Goal.goal sigma -> types -> (inductive * EInstance.t) * types +[@@ocaml.deprecated "Use Tacred.pf_reduce_to_atomic_ind"] val pf_compute : Goal.goal sigma -> constr -> constr +[@@ocaml.deprecated "Use the version in Tacmach.New"] val pf_unfoldn : (occurrences * evaluable_global_reference) list -> Goal.goal sigma -> constr -> constr +[@@ocaml.deprecated "Use Tacred.unfoldn"] val pf_const_value : Goal.goal sigma -> pconstant -> constr +[@@ocaml.deprecated "Use Environ.constant_value_in"] val pf_conv_x : Goal.goal sigma -> constr -> constr -> bool +[@@ocaml.deprecated "Use the version in Tacmach.New"] (** {6 Pretty-printing functions (debug only). } *) val pr_gls : Goal.goal sigma -> Pp.t diff --git a/stm/stm.ml b/stm/stm.ml index 73356c42f1..62556d38ff 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -878,7 +878,7 @@ end = struct (* {{{ *) Vernacstate.LemmaStack.t option * int * (* Evarutil.meta_counter_summary_tag *) int * (* Evd.evar_counter_summary_tag *) - DeclareObl.program_info CEphemeron.key Names.Id.Map.t (* Obligations.program_tcc_summary_tag *) + DeclareObl.ProgramDecl.t CEphemeron.key Names.Id.Map.t (* Obligations.program_tcc_summary_tag *) type partial_state = [ `Full of Vernacstate.t diff --git a/stm/vernac_classifier.ml b/stm/vernac_classifier.ml index 15e839c612..567acb1c73 100644 --- a/stm/vernac_classifier.ml +++ b/stm/vernac_classifier.ml @@ -130,7 +130,7 @@ let classify_vernac e = | VernacPrimitive (id,_,_) -> VtSideff ([id.CAst.v], VtLater) | VernacDefinition (_,({v=id},_),DefineBody _) -> VtSideff (idents_of_name id, VtLater) - | VernacInductive (_, _,_,l) -> + | VernacInductive (_,l) -> let ids = List.map (fun (((_,({v=id},_)),_,_,cl),_) -> id :: match cl with | Constructors l -> List.map (fun (_,({v=id},_)) -> id) l | RecordDecl (oid,l) -> (match oid with Some {v=x} -> [x] | _ -> []) @ diff --git a/tactics/abstract.ml b/tactics/abstract.ml index 9b0a323078..e85d94cd72 100644 --- a/tactics/abstract.ml +++ b/tactics/abstract.ml @@ -91,7 +91,7 @@ let cache_term_by_tactic_then ~opaque ~name_op ?(goal_type=None) tac tacK = let solve_tac = tclCOMPLETE (tclTHEN (tclDO (List.length sign) Tactics.intro) tac) in let ectx = Evd.evar_universe_context sigma in let (const, safe, ectx) = - try Pfedit.build_constant_by_tactic ~name ~opaque:Proof_global.Transparent ~poly ectx secsign concl solve_tac + try Pfedit.build_constant_by_tactic ~name ~opaque:Proof_global.Transparent ~poly ~uctx:ectx ~sign:secsign concl solve_tac with Logic_monad.TacticFailure e as src -> (* if the tactic [tac] fails, it reports a [TacticFailure e], which is an error irrelevant to the proof system (in fact it diff --git a/tactics/declare.ml b/tactics/declare.ml index de3c731d9b..5e6f78be6f 100644 --- a/tactics/declare.ml +++ b/tactics/declare.ml @@ -351,11 +351,11 @@ let declare_private_constant ?role ?(local = ImportDefaultBehavior) ~name ~kind let eff = { Evd.seff_private = eff; Evd.seff_roles; } in kn, eff -let inline_private_constants ~univs env ce = +let inline_private_constants ~uctx env ce = let body, eff = Future.force ce.proof_entry_body in let cb, ctx = Safe_typing.inline_private_constants env (body, eff.Evd.seff_private) in - let univs = UState.merge ~sideff:true Evd.univ_rigid univs ctx in - cb, univs + let uctx = UState.merge ~sideff:true Evd.univ_rigid uctx ctx in + cb, uctx (** Declaration of section variables and local definitions *) type variable_declaration = @@ -382,13 +382,13 @@ let declare_variable ~name ~kind d = | SectionLocalDef (de) -> (* The body should already have been forced upstream because it is a section-local definition, but it's not enforced by typing *) - let ((body, uctx), eff) = Future.force de.proof_entry_body in + let ((body, body_ui), eff) = Future.force de.proof_entry_body in let () = export_side_effects eff in - let poly, univs = match de.proof_entry_universes with + let poly, entry_ui = match de.proof_entry_universes with | Monomorphic_entry uctx -> false, uctx | Polymorphic_entry (_, uctx) -> true, Univ.ContextSet.of_context uctx in - let univs = Univ.ContextSet.union uctx univs in + let univs = Univ.ContextSet.union body_ui entry_ui in (* We must declare the universe constraints before type-checking the term. *) let () = declare_universe_context ~poly univs in diff --git a/tactics/declare.mli b/tactics/declare.mli index f87d08fc8b..0068b9842a 100644 --- a/tactics/declare.mli +++ b/tactics/declare.mli @@ -108,11 +108,11 @@ val declare_private_constant -> unit proof_entry -> Constant.t * Evd.side_effects -(** [inline_private_constants ~sideff ~univs env ce] will inline the +(** [inline_private_constants ~sideff ~uctx env ce] will inline the constants in [ce]'s body and return the body plus the updated [UState.t]. *) val inline_private_constants - : univs:UState.t + : uctx:UState.t -> Environ.env -> Evd.side_effects proof_entry -> Constr.t * UState.t diff --git a/tactics/pfedit.ml b/tactics/pfedit.ml index 438892e75e..b228a04298 100644 --- a/tactics/pfedit.ml +++ b/tactics/pfedit.ml @@ -116,31 +116,31 @@ let by tac = Proof_global.map_fold_proof (solve (Goal_select.SelectNth 1) None t let next = let n = ref 0 in fun () -> incr n; !n -let build_constant_by_tactic ~name ?(opaque=Proof_global.Transparent) ctx sign ~poly typ tac = - let evd = Evd.from_ctx ctx in +let build_constant_by_tactic ~name ?(opaque=Proof_global.Transparent) ~uctx ~sign ~poly typ tac = + let evd = Evd.from_ctx uctx in let goals = [ (Global.env_of_context sign , typ) ] in let pf = Proof_global.start_proof ~name ~poly ~udecl:UState.default_univ_decl evd goals in let pf, status = by tac pf in let open Proof_global in - let { entries; universes } = close_proof ~opaque ~keep_body_ucst_separate:false (fun x -> x) pf in + let { entries; uctx } = close_proof ~opaque ~keep_body_ucst_separate:false (fun x -> x) pf in match entries with | [entry] -> - entry, status, universes + entry, status, uctx | _ -> CErrors.anomaly Pp.(str "[build_constant_by_tactic] close_proof returned more than one proof term") -let build_by_tactic ?(side_eff=true) env sigma ~poly typ tac = +let build_by_tactic ?(side_eff=true) env ~uctx ~poly ~typ tac = let name = Id.of_string ("temporary_proof"^string_of_int (next())) in let sign = val_of_named_context (named_context env) in - let ce, status, univs = build_constant_by_tactic ~name sigma sign ~poly typ tac in - let cb, univs = - if side_eff then Declare.inline_private_constants ~univs env ce + let ce, status, univs = build_constant_by_tactic ~name ~uctx ~sign ~poly typ tac in + let cb, uctx = + if side_eff then Declare.inline_private_constants ~uctx env ce else (* GG: side effects won't get reset: no need to treat their universes specially *) let (cb, ctx), _eff = Future.force ce.Declare.proof_entry_body in - cb, UState.merge ~sideff:false Evd.univ_rigid univs ctx + cb, UState.merge ~sideff:false Evd.univ_rigid uctx ctx in - cb, status, univs + cb, ce.Declare.proof_entry_type, status, univs let refine_by_tactic ~name ~poly env sigma ty tac = (* Save the initial side-effects to restore them afterwards. We set the diff --git a/tactics/pfedit.mli b/tactics/pfedit.mli index 3cf3a13262..c49e997757 100644 --- a/tactics/pfedit.mli +++ b/tactics/pfedit.mli @@ -64,8 +64,8 @@ val use_unification_heuristics : unit -> bool val build_constant_by_tactic : name:Id.t -> ?opaque:Proof_global.opacity_flag - -> UState.t - -> named_context_val + -> uctx:UState.t + -> sign:named_context_val -> poly:bool -> EConstr.types -> unit Proofview.tactic @@ -74,11 +74,11 @@ val build_constant_by_tactic val build_by_tactic : ?side_eff:bool -> env - -> UState.t + -> uctx:UState.t -> poly:bool - -> EConstr.types + -> typ:EConstr.types -> unit Proofview.tactic - -> constr * bool * UState.t + -> constr * types option * bool * UState.t val refine_by_tactic : name:Id.t diff --git a/tactics/proof_global.ml b/tactics/proof_global.ml index 7d59a18494..620afbaf23 100644 --- a/tactics/proof_global.ml +++ b/tactics/proof_global.ml @@ -8,14 +8,6 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -(***********************************************************************) -(* *) -(* This module defines proof facilities relevant to the *) -(* toplevel. In particular it defines the global proof *) -(* environment. *) -(* *) -(***********************************************************************) - open Util open Names open Context @@ -26,10 +18,9 @@ module NamedDecl = Context.Named.Declaration type proof_object = { name : Names.Id.t + (* [name] only used in the STM *) ; entries : Evd.side_effects Declare.proof_entry list - ; poly : bool - ; universes: UState.t - ; udecl : UState.universe_decl + ; uctx: UState.t } type opacity_flag = Opaque | Transparent @@ -159,7 +150,7 @@ let close_proof ~opaque ~keep_body_ucst_separate ?feedback_id ~now UState.constrain_variables (fst (UState.context_set initial_euctx)) ctx in let fpl, univs = Future.split2 fpl in - let universes = if poly || now then Future.force univs else initial_euctx in + let uctx = if poly || now then Future.force univs else initial_euctx in (* Because of dependent subgoals at the beginning of proofs, we could have existential variables in the initial types of goals, we need to normalise them for the kernel. *) @@ -167,7 +158,7 @@ let close_proof ~opaque ~keep_body_ucst_separate ?feedback_id ~now let { Proof.sigma } = Proof.data proof in Evd.existential_opt_value0 sigma k in let nf = UnivSubst.nf_evars_and_universes_opt_subst subst_evar - (UState.subst universes) in + (UState.subst uctx) in let make_body = if poly || now then @@ -182,7 +173,7 @@ let close_proof ~opaque ~keep_body_ucst_separate ?feedback_id ~now let used_univs_typ = Vars.universes_of_constr typ in if allow_deferred then let initunivs = UState.univ_entry ~poly initial_euctx in - let ctx = constrain_variables universes in + let ctx = constrain_variables uctx in (* For vi2vo compilation proofs are computed now but we need to complement the univ constraints of the typ with the ones of the body. So we keep the two sets distinct. *) @@ -192,7 +183,7 @@ let close_proof ~opaque ~keep_body_ucst_separate ?feedback_id ~now (initunivs, typ), ((body, univs), eff) else if poly && opaque && private_poly_univs () then let used_univs = Univ.LSet.union used_univs_body used_univs_typ in - let universes = UState.restrict universes used_univs in + let universes = UState.restrict uctx used_univs in let typus = UState.restrict universes used_univs_typ in let udecl = UState.check_univ_decl ~poly typus udecl in let ubody = Univ.ContextSet.diff @@ -207,7 +198,7 @@ let close_proof ~opaque ~keep_body_ucst_separate ?feedback_id ~now the actually used universes. TODO: check if restrict is really necessary now. *) let used_univs = Univ.LSet.union used_univs_body used_univs_typ in - let ctx = UState.restrict universes used_univs in + let ctx = UState.restrict uctx used_univs in let univs = UState.check_univ_decl ~poly ctx udecl in (univs, typ), ((body, Univ.ContextSet.empty), eff) in @@ -215,7 +206,7 @@ let close_proof ~opaque ~keep_body_ucst_separate ?feedback_id ~now else fun t p -> (* Already checked the univ_decl for the type universes when starting the proof. *) - let univctx = UState.univ_entry ~poly:false universes in + let univctx = UState.univ_entry ~poly:false uctx in let t = nf t in Future.from_val (univctx, t), Future.chain p (fun (pt,eff) -> @@ -240,7 +231,7 @@ let close_proof ~opaque ~keep_body_ucst_separate ?feedback_id ~now Declare.delayed_definition_entry ~opaque ?feedback_id ?section_vars ~univs ~types:typ body in let entries = Future.map2 entry_fn fpl (Proofview.initial_goals entry) in - { name; entries; poly; universes; udecl } + { name; entries; uctx } let return_proof ?(allow_partial=false) ps = let { proof } = ps in diff --git a/tactics/proof_global.mli b/tactics/proof_global.mli index 8c1bc0def1..d820fc8b40 100644 --- a/tactics/proof_global.mli +++ b/tactics/proof_global.mli @@ -8,9 +8,7 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -(** This module defines proof facilities relevant to the - toplevel. In particular it defines the global proof - environment. *) +(** State for interactive proofs. *) type t @@ -33,12 +31,8 @@ type proof_object = (** name of the proof *) ; entries : Evd.side_effects Declare.proof_entry list (** list of the proof terms (in a form suitable for definitions). *) - ; poly : bool - (** polymorphic status *) - ; universes: UState.t + ; uctx: UState.t (** universe state *) - ; udecl : UState.universe_decl - (** universe declaration *) } type opacity_flag = Opaque | Transparent diff --git a/test-suite/Makefile b/test-suite/Makefile index aca7ab0b28..0d8a6ebed7 100644 --- a/test-suite/Makefile +++ b/test-suite/Makefile @@ -49,7 +49,8 @@ endif endif # exists ../_build export COQLIB -COQFLAGS?= +COQEXTRAFLAGS?= +COQFLAGS?=$(COQEXTRAFLAGS) coqc := $(BIN)coqc -q -R prerequisite TestSuite $(COQFLAGS) coqchk := $(BIN)coqchk -R prerequisite TestSuite @@ -416,14 +417,16 @@ $(addsuffix .log,$(wildcard output/*.v)): %.v.log: %.v %.out $(PREREQUISITELOG) $(HIDE){ \ echo $(call log_intro,$<); \ output=$*.out.real; \ + export LC_CTYPE=C; \ + export LANG=C; \ $(coqc_interactive) "$<" $(call get_coq_prog_args,"$<") 2>&1 \ - | grep -v "Welcome to Coq" \ - | grep -v "\[Loading ML file" \ - | grep -v "Skipping rcfile loading" \ - | grep -v "^<W>" \ + | grep -a -v "Welcome to Coq" \ + | grep -a -v "\[Loading ML file" \ + | grep -a -v "Skipping rcfile loading" \ + | grep -a -v "^<W>" \ | sed 's/File "[^"]*"/File "stdin"/' \ > $$output; \ - diff -u --strip-trailing-cr $*.out $$output 2>&1; R=$$?; times; \ + diff -a -u --strip-trailing-cr $*.out $$output 2>&1; R=$$?; times; \ if [ $$R = 0 ]; then \ echo $(log_success); \ echo " $<...Ok"; \ diff --git a/test-suite/bugs/closed/HoTT_coq_010.v b/test-suite/bugs/closed/HoTT_coq_010.v index 42b1244fb5..caa7373f5e 100644 --- a/test-suite/bugs/closed/HoTT_coq_010.v +++ b/test-suite/bugs/closed/HoTT_coq_010.v @@ -1,3 +1,3 @@ -SearchAbout and. +Search and. (* Anomaly: Mismatched instance and context when building universe substitution. Please report. *) diff --git a/test-suite/bugs/closed/bug_11845.v b/test-suite/bugs/closed/bug_11845.v new file mode 100644 index 0000000000..d27f8c4ef0 --- /dev/null +++ b/test-suite/bugs/closed/bug_11845.v @@ -0,0 +1,6 @@ + +Module Type T. Parameter Inline v : Prop. End T. + +Module F(A:T). End F. + +Fail Include F. diff --git a/test-suite/bugs/closed/bug_11846.v b/test-suite/bugs/closed/bug_11846.v new file mode 100644 index 0000000000..53517e7703 --- /dev/null +++ b/test-suite/bugs/closed/bug_11846.v @@ -0,0 +1,16 @@ +Require Import FunInd. + +Inductive tree : Type := +| Node : unit -> tree. + +Definition height (s : tree) : unit := +match s with +| Node h => h +end. + +Definition bal : forall l, let h := height l in tree := fun l => + let h := height l in + Node h. + +Set Warnings "+all". +Functional Scheme bal_ind := Induction for bal Sort Prop. diff --git a/test-suite/bugs/closed/bug_11890.v b/test-suite/bugs/closed/bug_11890.v new file mode 100644 index 0000000000..c0426fcfda --- /dev/null +++ b/test-suite/bugs/closed/bug_11890.v @@ -0,0 +1,10 @@ +Require Import Coq.Structures.Orders Coq.ZArith.ZArith Coq.Sorting.Mergesort. +(* Note that this has always worked fine without the '; we are testing importing notations from the stdlib here *) +Declare Module A : LeBool'. +Declare Module B : LtBool'. +Import A B NatOrder. +(* +Error: Notation "_ <=? _" is already defined at level 70 with arguments constr +at next level, constr at next level while it is now required to be at level 35 +with arguments constr at next level, constr at next level. +*) diff --git a/test-suite/bugs/closed/bug_3900.v b/test-suite/bugs/closed/bug_3900.v index 6be2161c2f..ddede74acc 100644 --- a/test-suite/bugs/closed/bug_3900.v +++ b/test-suite/bugs/closed/bug_3900.v @@ -9,5 +9,5 @@ Variable Pmor : forall s d : obj, morphism A (projT1 s) (projT1 d) -> Type. Class Foo (x : Type) := { _ : forall y, y }. Local Instance ishset_pmor {s d m} : Foo (Pmor s d m). Proof. -SearchAbout ((forall _ _, _) -> Foo _). +Search ((forall _ _, _) -> Foo _). Abort. diff --git a/test-suite/coq-makefile/native1/run.sh b/test-suite/coq-makefile/native1/run.sh index 8f9ab9a711..3ffe831b3c 100755 --- a/test-suite/coq-makefile/native1/run.sh +++ b/test-suite/coq-makefile/native1/run.sh @@ -1,7 +1,7 @@ #!/usr/bin/env bash -NATIVECOMP=$(grep "let no_native_compiler = false" ../../../config/coq_config.ml)||true -if [[ $(which ocamlopt) && $NATIVECOMP ]]; then +NONATIVECOMP=$(grep "let native_compiler = false" ../../../config/coq_config.ml)||true +if [[ $(which ocamlopt) && ! $NONATIVECOMP ]]; then . ../template/init.sh diff --git a/test-suite/coq-makefile/native2/_CoqProject b/test-suite/coq-makefile/native2/_CoqProject new file mode 100644 index 0000000000..61136e82f0 --- /dev/null +++ b/test-suite/coq-makefile/native2/_CoqProject @@ -0,0 +1,10 @@ +-R src test +-R theories test +-I src + +src/test_plugin.mlpack +src/test.mlg +src/test.mli +src/test_aux.ml +src/test_aux.mli +theories/test.v diff --git a/test-suite/coq-makefile/native2/run.sh b/test-suite/coq-makefile/native2/run.sh new file mode 100755 index 0000000000..857f70fdff --- /dev/null +++ b/test-suite/coq-makefile/native2/run.sh @@ -0,0 +1,33 @@ +#!/usr/bin/env bash + +NONATIVECOMP=$(grep "let native_compiler = false" ../../../config/coq_config.ml)||true +if [[ $(which ocamlopt) && ! $NONATIVECOMP ]]; then + +. ../template/init.sh + +coq_makefile -f _CoqProject -o Makefile +cat Makefile.conf +COQEXTRAFLAGS="-native-compiler yes" make +make html mlihtml +make install DSTROOT="$PWD/tmp" +#make debug +(cd "$(find tmp -name user-contrib)" && find .) | sort > actual +sort > desired <<EOT +. +./test +./test/test.glob +./test/test_plugin.cmi +./test/test_plugin.cmx +./test/test_plugin.cmxa +./test/test_plugin.cmxs +./test/test.v +./test/test.vo +./test/.coq-native +./test/.coq-native/Ntest_test.cmi +./test/.coq-native/Ntest_test.cmx +./test/.coq-native/Ntest_test.cmxs +EOT +exec diff -u desired actual + +fi +exit 0 # test skipped diff --git a/test-suite/output/FloatExtraction.out b/test-suite/output/FloatExtraction.out index cfd6633752..dd8189c56f 100644 --- a/test-suite/output/FloatExtraction.out +++ b/test-suite/output/FloatExtraction.out @@ -1,3 +1,17 @@ +File "stdin", line 25, characters 8-12: +Warning: The constant 0.01 is not a binary64 floating-point value. A closest +value will be used and unambiguously printed 0.01. [inexact-float,parsing] +File "stdin", line 25, characters 20-25: +Warning: The constant -0.01 is not a binary64 floating-point value. A closest +value will be used and unambiguously printed -0.01. [inexact-float,parsing] +File "stdin", line 25, characters 27-35: +Warning: The constant 1.7e+308 is not a binary64 floating-point value. A +closest value will be used and unambiguously printed 1.6999999999999999e+308. +[inexact-float,parsing] +File "stdin", line 25, characters 37-46: +Warning: The constant -1.7e-308 is not a binary64 floating-point value. A +closest value will be used and unambiguously printed +-1.7000000000000002e-308. [inexact-float,parsing] (** val infinity : Float64.t **) diff --git a/test-suite/output/FloatSyntax.out b/test-suite/output/FloatSyntax.out index 668a55977d..7941d2e647 100644 --- a/test-suite/output/FloatSyntax.out +++ b/test-suite/output/FloatSyntax.out @@ -4,8 +4,16 @@ : float (-2.5)%float : float +File "stdin", line 9, characters 6-13: +Warning: The constant 2.5e123 is not a binary64 floating-point value. A +closest value will be used and unambiguously printed 2.4999999999999999e+123. +[inexact-float,parsing] 2.4999999999999999e+123%float : float +File "stdin", line 10, characters 7-16: +Warning: The constant -2.5e-123 is not a binary64 floating-point value. A +closest value will be used and unambiguously printed +-2.5000000000000001e-123. [inexact-float,parsing] (-2.5000000000000001e-123)%float : float (2 + 2)%float @@ -18,14 +26,34 @@ : float -2.5 : float +File "stdin", line 19, characters 6-13: +Warning: The constant 2.5e123 is not a binary64 floating-point value. A +closest value will be used and unambiguously printed 2.4999999999999999e+123. +[inexact-float,parsing] 2.4999999999999999e+123 : float +File "stdin", line 20, characters 7-16: +Warning: The constant -2.5e-123 is not a binary64 floating-point value. A +closest value will be used and unambiguously printed +-2.5000000000000001e-123. [inexact-float,parsing] -2.5000000000000001e-123 : float 2 + 2 : float 2.5 + 2.5 : float +File "stdin", line 24, characters 6-11: +Warning: The constant 1e309 is not a binary64 floating-point value. A closest +value will be used and unambiguously printed infinity. +[inexact-float,parsing] +infinity + : float +File "stdin", line 25, characters 6-12: +Warning: The constant -1e309 is not a binary64 floating-point value. A +closest value will be used and unambiguously printed neg_infinity. +[inexact-float,parsing] +neg_infinity + : float 2 : nat 2%float diff --git a/test-suite/output/FloatSyntax.v b/test-suite/output/FloatSyntax.v index 85f611352c..eca712db10 100644 --- a/test-suite/output/FloatSyntax.v +++ b/test-suite/output/FloatSyntax.v @@ -21,6 +21,9 @@ Check (-2.5e-123). Check (2 + 2). Check (2.5 + 2.5). +Check 1e309. +Check -1e309. + Open Scope nat_scope. Check 2. diff --git a/test-suite/output/NoAxiomFromR.v b/test-suite/output/NoAxiomFromR.v index 9cf6879699..7abbe29452 100644 --- a/test-suite/output/NoAxiomFromR.v +++ b/test-suite/output/NoAxiomFromR.v @@ -5,6 +5,6 @@ Inductive TT : Set := Lemma lem4 : forall (n m : nat), S m <= m -> C (S m) <> C n -> False. -Proof. firstorder. Qed. +Proof. firstorder lia. Qed. Print Assumptions lem4. diff --git a/test-suite/output/NumeralNotations.out b/test-suite/output/NumeralNotations.out index 113384e9cf..060877707b 100644 --- a/test-suite/output/NumeralNotations.out +++ b/test-suite/output/NumeralNotations.out @@ -218,3 +218,19 @@ let v : ty := Build_ty Set set in v : ty : ty let v : ty := Build_ty Type type in v : ty : ty +1 + : nat +(-1000)%Z + : Z +0 + : Prop ++0 + : bool +-0 + : bool +00 + : nat * nat +1000 + : Prop +1_000 + : list nat diff --git a/test-suite/output/NumeralNotations.v b/test-suite/output/NumeralNotations.v index 22aff36d67..47e1b127cb 100644 --- a/test-suite/output/NumeralNotations.v +++ b/test-suite/output/NumeralNotations.v @@ -457,3 +457,33 @@ Module Test20. Check let v := 4%kt in v : ty. Check let v := 5%kt in v : ty. End Test20. + +Module Test21. + + Check 00001. + Check (-1_000)%Z. + +End Test21. + +Module Test22. + +Notation "0" := False. +Notation "+0" := true. +Notation "-0" := false. +Notation "00" := (0%nat, 0%nat). +Check 0. +Check +0. +Check -0. +Check 00. + +Notation "1000" := True. +Notation "1_000" := (cons 1 nil). +Check 1000. +Check 1_000. + +(* To do: preserve parsing of -0: +Require Import ZArith. +Check (-0)%Z. +*) + +End Test22. diff --git a/test-suite/output/PatternsInBinders.out b/test-suite/output/PatternsInBinders.out index 4f09f00c56..bdfa8afb6a 100644 --- a/test-suite/output/PatternsInBinders.out +++ b/test-suite/output/PatternsInBinders.out @@ -4,7 +4,7 @@ fun '(x, y) => (y, x) : A * B -> B * A forall '(x, y), swap (x, y) = (y, x) : Prop -proj_informative = fun '(exist _ x _) => x : A +proj_informative = fun '(exist _ x _) => x : {x : A | P x} -> A foo = fun '(Bar n b tt p) => if b then n + p else n - p : Foo -> nat @@ -29,8 +29,7 @@ exists '(x, y) '(z, w), swap (x, y) = (z, w) ∀ '(x, y), swap (x, y) = (y, x) : Prop both_z = -fun pat : nat * nat => -let '(n, p) as x := pat return (F x) in (Z n, Z p) : F (n, p) +fun pat : nat * nat => let '(n, p) as x := pat return (F x) in (Z n, Z p) : forall pat : nat * nat, F pat fun '(x, y) '(z, t) => swap (x, y) = (z, t) : A * B -> B * A -> Prop diff --git a/test-suite/output/QArithSyntax.out b/test-suite/output/QArithSyntax.out index 6bc04f1cef..fe6a1d25c6 100644 --- a/test-suite/output/QArithSyntax.out +++ b/test-suite/output/QArithSyntax.out @@ -1,14 +1,14 @@ -eq_refl : 102e-2 = 102e-2 - : 102e-2 = 102e-2 -eq_refl : 102e-1 = 102e-1 - : 102e-1 = 102e-1 +eq_refl : 1.02 = 1.02 + : 1.02 = 1.02 +eq_refl : 10.2 = 10.2 + : 10.2 = 10.2 eq_refl : 1020 = 1020 : 1020 = 1020 eq_refl : 102 = 102 : 102 = 102 -eq_refl : 102e-2 = 102e-2 - : 102e-2 = 102e-2 +eq_refl : 1.02 = 1.02 + : 1.02 = 1.02 eq_refl : -1e-4 = -1e-4 : -1e-4 = -1e-4 -eq_refl : -50e-2 = -50e-2 - : -50e-2 = -50e-2 +eq_refl : -0.50 = -0.50 + : -0.50 = -0.50 diff --git a/test-suite/output/RealSyntax.out b/test-suite/output/RealSyntax.out index 2b14ca7069..1685964b0f 100644 --- a/test-suite/output/RealSyntax.out +++ b/test-suite/output/RealSyntax.out @@ -2,19 +2,21 @@ : R (-31)%R : R -15e-1%R +1.5%R : R -eq_refl : 102e-2 = 102e-2 - : 102e-2 = 102e-2 -eq_refl : 102e-1 = 102e-1 - : 102e-1 = 102e-1 +15%R + : R +eq_refl : 1.02 = 1.02 + : 1.02 = 1.02 +eq_refl : 10.2 = 10.2 + : 10.2 = 10.2 eq_refl : 102e1 = 102e1 : 102e1 = 102e1 eq_refl : 102 = 102 : 102 = 102 -eq_refl : 102e-2 = 102e-2 - : 102e-2 = 102e-2 +eq_refl : 1.02 = 1.02 + : 1.02 = 1.02 eq_refl : -1e-4 = -1e-4 : -1e-4 = -1e-4 -eq_refl : -50e-2 = -50e-2 - : -50e-2 = -50e-2 +eq_refl : -0.50 = -0.50 + : -0.50 = -0.50 diff --git a/test-suite/output/RealSyntax.v b/test-suite/output/RealSyntax.v index 7be8b18ac8..e5f9d06316 100644 --- a/test-suite/output/RealSyntax.v +++ b/test-suite/output/RealSyntax.v @@ -3,6 +3,7 @@ Check 32%R. Check (-31)%R. Check 1.5_%R. +Check 1_.5_e1_%R. Open Scope R_scope. diff --git a/test-suite/output/allBytes.out b/test-suite/output/allBytes.out new file mode 100644 index 0000000000..8d188c4c45 --- /dev/null +++ b/test-suite/output/allBytes.out @@ -0,0 +1 @@ +!"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefghijklmnopqrstuvwxyz{|}~ diff --git a/test-suite/output/allBytes.v b/test-suite/output/allBytes.v new file mode 100644 index 0000000000..01a5161ef4 --- /dev/null +++ b/test-suite/output/allBytes.v @@ -0,0 +1,121 @@ +(* Taken from bedrock2 *) + +(* Note: not an utf8 file *) + +Require Import Coq.ZArith.BinInt Coq.Lists.List. +Require Coq.Init.Byte Coq.Strings.Byte Coq.Strings.String. + +Definition allBytes: list Byte.byte := + map (fun nn => match Byte.of_N (BinNat.N.of_nat nn) with + | Some b => b + | None => Byte.x00 (* won't happen *) + end) + (seq 32 95). + +Notation "a b" := (@cons Byte.byte a b) + (only printing, right associativity, at level 3, format "a b"). + +Notation "" := (@nil Byte.byte) + (only printing, right associativity, at level 3, format ""). + +Notation " " := (Byte.x20) (only printing). +Notation "'!'" := (Byte.x21) (only printing). +Notation "'""'" := (Byte.x22) (only printing). +Notation "'#'" := (Byte.x23) (only printing). +Notation "'$'" := (Byte.x24) (only printing). +Notation "'%'" := (Byte.x25) (only printing). +Notation "'&'" := (Byte.x26) (only printing). +Notation "'''" := (Byte.x27) (only printing). +Notation "'('" := (Byte.x28) (only printing). +Notation "')'" := (Byte.x29) (only printing). +Notation "'*'" := (Byte.x2a) (only printing). +Notation "'+'" := (Byte.x2b) (only printing). +Notation "','" := (Byte.x2c) (only printing). +Notation "'-'" := (Byte.x2d) (only printing). +Notation "'.'" := (Byte.x2e) (only printing). +Notation "'/'" := (Byte.x2f) (only printing). +Notation "'0'" := (Byte.x30) (only printing). +Notation "'1'" := (Byte.x31) (only printing). +Notation "'2'" := (Byte.x32) (only printing). +Notation "'3'" := (Byte.x33) (only printing). +Notation "'4'" := (Byte.x34) (only printing). +Notation "'5'" := (Byte.x35) (only printing). +Notation "'6'" := (Byte.x36) (only printing). +Notation "'7'" := (Byte.x37) (only printing). +Notation "'8'" := (Byte.x38) (only printing). +Notation "'9'" := (Byte.x39) (only printing). +Notation "':'" := (Byte.x3a) (only printing). +Notation "';'" := (Byte.x3b) (only printing). +Notation "'<'" := (Byte.x3c) (only printing). +Notation "'='" := (Byte.x3d) (only printing). +Notation "'>'" := (Byte.x3e) (only printing). +Notation "'?'" := (Byte.x3f) (only printing). +Notation "'@'" := (Byte.x40) (only printing). +Notation "'A'" := (Byte.x41) (only printing). +Notation "'B'" := (Byte.x42) (only printing). +Notation "'C'" := (Byte.x43) (only printing). +Notation "'D'" := (Byte.x44) (only printing). +Notation "'E'" := (Byte.x45) (only printing). +Notation "'F'" := (Byte.x46) (only printing). +Notation "'G'" := (Byte.x47) (only printing). +Notation "'H'" := (Byte.x48) (only printing). +Notation "'I'" := (Byte.x49) (only printing). +Notation "'J'" := (Byte.x4a) (only printing). +Notation "'K'" := (Byte.x4b) (only printing). +Notation "'L'" := (Byte.x4c) (only printing). +Notation "'M'" := (Byte.x4d) (only printing). +Notation "'N'" := (Byte.x4e) (only printing). +Notation "'O'" := (Byte.x4f) (only printing). +Notation "'P'" := (Byte.x50) (only printing). +Notation "'Q'" := (Byte.x51) (only printing). +Notation "'R'" := (Byte.x52) (only printing). +Notation "'S'" := (Byte.x53) (only printing). +Notation "'T'" := (Byte.x54) (only printing). +Notation "'U'" := (Byte.x55) (only printing). +Notation "'V'" := (Byte.x56) (only printing). +Notation "'W'" := (Byte.x57) (only printing). +Notation "'X'" := (Byte.x58) (only printing). +Notation "'Y'" := (Byte.x59) (only printing). +Notation "'Z'" := (Byte.x5a) (only printing). +Notation "'['" := (Byte.x5b) (only printing). +Notation "'\'" := (Byte.x5c) (only printing). +Notation "']'" := (Byte.x5d) (only printing). +Notation "'^'" := (Byte.x5e) (only printing). +Notation "'_'" := (Byte.x5f) (only printing). +Notation "'`'" := (Byte.x60) (only printing). +Notation "'a'" := (Byte.x61) (only printing). +Notation "'b'" := (Byte.x62) (only printing). +Notation "'c'" := (Byte.x63) (only printing). +Notation "'d'" := (Byte.x64) (only printing). +Notation "'e'" := (Byte.x65) (only printing). +Notation "'f'" := (Byte.x66) (only printing). +Notation "'g'" := (Byte.x67) (only printing). +Notation "'h'" := (Byte.x68) (only printing). +Notation "'i'" := (Byte.x69) (only printing). +Notation "'j'" := (Byte.x6a) (only printing). +Notation "'k'" := (Byte.x6b) (only printing). +Notation "'l'" := (Byte.x6c) (only printing). +Notation "'m'" := (Byte.x6d) (only printing). +Notation "'n'" := (Byte.x6e) (only printing). +Notation "'o'" := (Byte.x6f) (only printing). +Notation "'p'" := (Byte.x70) (only printing). +Notation "'q'" := (Byte.x71) (only printing). +Notation "'r'" := (Byte.x72) (only printing). +Notation "'s'" := (Byte.x73) (only printing). +Notation "'t'" := (Byte.x74) (only printing). +Notation "'u'" := (Byte.x75) (only printing). +Notation "'v'" := (Byte.x76) (only printing). +Notation "'w'" := (Byte.x77) (only printing). +Notation "'x'" := (Byte.x78) (only printing). +Notation "'y'" := (Byte.x79) (only printing). +Notation "'z'" := (Byte.x7a) (only printing). +Notation "'{'" := (Byte.x7b) (only printing). +Notation "'|'" := (Byte.x7c) (only printing). +Notation "'}'" := (Byte.x7d) (only printing). +Notation "'~'" := (Byte.x7e) (only printing). + +Global Set Printing Width 300. + +Goal False. + let cc := eval cbv in allBytes in idtac cc. +Abort. diff --git a/test-suite/success/attribute_syntax.v b/test-suite/success/attribute_syntax.v index 4717759dec..b403fc120c 100644 --- a/test-suite/success/attribute_syntax.v +++ b/test-suite/success/attribute_syntax.v @@ -36,3 +36,10 @@ Check M.zed@{_}. Fail Check zed. Check M.kats@{_}. Fail Check kats. + +Export Set Foo. + +#[ export ] Set Foo. + +Fail #[ export ] Export Foo. +(* Attribute for Locality specified twice *) diff --git a/test-suite/success/search.v b/test-suite/success/search.v new file mode 100644 index 0000000000..92de43e052 --- /dev/null +++ b/test-suite/success/search.v @@ -0,0 +1,35 @@ + +(** Test of the different syntaxes of Search *) + +Search plus. +Search plus mult. +Search "plus_n". +Search plus "plus_n". +Search "*". +Search "*" "+". + +Search plus inside Peano. +Search plus mult inside Peano. +Search "plus_n" inside Peano. +Search plus "plus_n" inside Peano. +Search "*" inside Peano. +Search "*" "+" inside Peano. + +Search plus outside Peano Logic. +Search plus mult outside Peano Logic. +Search "plus_n" outside Peano Logic. +Search plus "plus_n" outside Peano Logic. +Search "*" outside Peano Logic. +Search "*" "+" outside Peano Logic. + +Search -"*" "+" outside Logic. +Search -"*"%nat "+"%nat outside Logic. + + +(** The example in the Reference Manual *) + +Require Import ZArith. + +Search Z.mul Z.add "distr". +Search "+"%Z "*"%Z "distr" -positive -Prop. +Search (?x * _ + ?x * _)%Z outside OmegaLemmas. diff --git a/test-suite/success/searchabout.v b/test-suite/success/searchabout.v deleted file mode 100644 index 9edfd82556..0000000000 --- a/test-suite/success/searchabout.v +++ /dev/null @@ -1,60 +0,0 @@ - -(** Test of the different syntaxes of SearchAbout, in particular - with and without the [ ... ] delimiters *) - -SearchAbout plus. -SearchAbout plus mult. -SearchAbout "plus_n". -SearchAbout plus "plus_n". -SearchAbout "*". -SearchAbout "*" "+". - -SearchAbout plus inside Peano. -SearchAbout plus mult inside Peano. -SearchAbout "plus_n" inside Peano. -SearchAbout plus "plus_n" inside Peano. -SearchAbout "*" inside Peano. -SearchAbout "*" "+" inside Peano. - -SearchAbout plus outside Peano Logic. -SearchAbout plus mult outside Peano Logic. -SearchAbout "plus_n" outside Peano Logic. -SearchAbout plus "plus_n" outside Peano Logic. -SearchAbout "*" outside Peano Logic. -SearchAbout "*" "+" outside Peano Logic. - -SearchAbout -"*" "+" outside Logic. -SearchAbout -"*"%nat "+"%nat outside Logic. - -SearchAbout [plus]. -SearchAbout [plus mult]. -SearchAbout ["plus_n"]. -SearchAbout [plus "plus_n"]. -SearchAbout ["*"]. -SearchAbout ["*" "+"]. - -SearchAbout [plus] inside Peano. -SearchAbout [plus mult] inside Peano. -SearchAbout ["plus_n"] inside Peano. -SearchAbout [plus "plus_n"] inside Peano. -SearchAbout ["*"] inside Peano. -SearchAbout ["*" "+"] inside Peano. - -SearchAbout [plus] outside Peano Logic. -SearchAbout [plus mult] outside Peano Logic. -SearchAbout ["plus_n"] outside Peano Logic. -SearchAbout [plus "plus_n"] outside Peano Logic. -SearchAbout ["*"] outside Peano Logic. -SearchAbout ["*" "+"] outside Peano Logic. - -SearchAbout [-"*" "+"] outside Logic. -SearchAbout [-"*"%nat "+"%nat] outside Logic. - - -(** The example in the Reference Manual *) - -Require Import ZArith. - -SearchAbout Z.mul Z.add "distr". -SearchAbout "+"%Z "*"%Z "distr" -positive -Prop. -SearchAbout (?x * _ + ?x * _)%Z outside OmegaLemmas. diff --git a/theories/Classes/CMorphisms.v b/theories/Classes/CMorphisms.v index c247bc11dc..598bd8b9c5 100644 --- a/theories/Classes/CMorphisms.v +++ b/theories/Classes/CMorphisms.v @@ -638,7 +638,7 @@ Instance PartialOrder_proper_type `(PartialOrder A eqA R) : Proper (eqA==>eqA==>iffT) R. Proof. intros. -apply proper_sym_arrow_iffT_2; auto with *. +apply proper_sym_arrow_iffT_2. 1-2: auto with crelations. intros x x' Hx y y' Hy Hr. transitivity x. - generalize (partial_order_equivalence x x'); compute; intuition. diff --git a/theories/Classes/Morphisms.v b/theories/Classes/Morphisms.v index 5adb927357..43adb0b69f 100644 --- a/theories/Classes/Morphisms.v +++ b/theories/Classes/Morphisms.v @@ -640,7 +640,7 @@ Instance PartialOrder_proper `(PartialOrder A eqA R) : Proper (eqA==>eqA==>iff) R. Proof. intros. -apply proper_sym_impl_iff_2; auto with *. +apply proper_sym_impl_iff_2. 1-2: auto with relations. intros x x' Hx y y' Hy Hr. transitivity x. - generalize (partial_order_equivalence x x'); compute; intuition. diff --git a/theories/Classes/Morphisms_Prop.v b/theories/Classes/Morphisms_Prop.v index 418f7a8767..7d0382ec43 100644 --- a/theories/Classes/Morphisms_Prop.v +++ b/theories/Classes/Morphisms_Prop.v @@ -75,7 +75,7 @@ Instance Acc_pt_morphism {A:Type}(E R : A->A->Prop) `(Equivalence _ E) `(Proper _ (E==>E==>iff) R) : Proper (E==>iff) (Acc R). Proof. - apply proper_sym_impl_iff; auto with *. + apply proper_sym_impl_iff. auto with relations. intros x y EQ WF. apply Acc_intro; intros z Hz. rewrite <- EQ in Hz. now apply Acc_inv with x. Qed. diff --git a/theories/Compat/Coq812.v b/theories/Compat/Coq812.v index d628456c78..ee4bac3542 100644 --- a/theories/Compat/Coq812.v +++ b/theories/Compat/Coq812.v @@ -9,3 +9,4 @@ (************************************************************************) (** Compatibility file for making Coq act similar to Coq v8.12 *) +Set Firstorder Solver auto with *. diff --git a/theories/FSets/FMapAVL.v b/theories/FSets/FMapAVL.v index 8cdc6e54c5..82055c4752 100644 --- a/theories/FSets/FMapAVL.v +++ b/theories/FSets/FMapAVL.v @@ -1335,7 +1335,7 @@ Proof. apply Hl; auto. constructor. apply Hr; eauto. - apply InA_InfA with (eqA:=eqke); auto with *. intros (y',e') H6. + apply InA_InfA with (eqA:=eqke). auto with typeclass_instances. intros (y',e') H6. destruct (elements_aux_mapsto r acc y' e'); intuition. red; simpl; eauto. red; simpl; eauto with ordered_type. diff --git a/theories/FSets/FMapFacts.v b/theories/FSets/FMapFacts.v index 1eb6a3f372..2001201ec3 100644 --- a/theories/FSets/FMapFacts.v +++ b/theories/FSets/FMapFacts.v @@ -760,7 +760,7 @@ Module WProperties_fun (E:DecidableType)(M:WSfun E). Instance eqke_equiv : Equivalence eqke. Proof. unfold eq_key_elt; split; repeat red; firstorder. - eauto with *. + eauto. congruence. Qed. @@ -910,9 +910,9 @@ Module WProperties_fun (E:DecidableType)(M:WSfun E). assert (Hstep' : forall k e a m' m'', InA eqke (k,e) l -> ~In k m' -> Add k e m' m'' -> P m' a -> P m'' (F (k,e) a)). intros k e a m' m'' H ? ? ?; eapply Hstep; eauto. - revert H; unfold l; rewrite InA_rev, elements_mapsto_iff; auto with *. + revert H; unfold l; rewrite InA_rev, elements_mapsto_iff. auto. assert (Hdup : NoDupA eqk l). - unfold l. apply NoDupA_rev; try red; unfold eq_key ; eauto with *. + unfold l. apply NoDupA_rev; try red; unfold eq_key. auto with typeclass_instances. apply elements_3w. assert (Hsame : forall k, find k m = findA (eqb k) l). intros k. unfold l. rewrite elements_o, findA_rev; auto. @@ -993,7 +993,7 @@ Module WProperties_fun (E:DecidableType)(M:WSfun E). rewrite 2 fold_spec_right. set (l:=rev (elements m)). assert (Rstep' : forall k e a b, InA eqke (k,e) l -> R a b -> R (f k e a) (g k e b)) by - (intros; apply Rstep; auto; rewrite elements_mapsto_iff, <- InA_rev; auto with *). + (intros; apply Rstep; auto; rewrite elements_mapsto_iff, <- InA_rev; assumption). clearbody l; clear Rstep m. induction l; simpl; auto. apply Rstep'; auto. @@ -1107,17 +1107,20 @@ Module WProperties_fun (E:DecidableType)(M:WSfun E). Proof. intros. rewrite 2 fold_spec_right. - assert (NoDupA eqk (rev (elements m1))) by (auto with *). - assert (NoDupA eqk (rev (elements m2))) by (auto with *). - apply fold_right_equivlistA_restr with (R:=complement eqk)(eqA:=eqke); - auto with *. + assert (NoDupA eqk (rev (elements m1))) by auto with map typeclass_instances. + assert (NoDupA eqk (rev (elements m2))) by auto with map typeclass_instances. + apply fold_right_equivlistA_restr with (R:=complement eqk)(eqA:=eqke). + auto with typeclass_instances. + auto. + 2: auto with crelations. + 4, 5: auto with map. intros (k1,e1) (k2,e2) (Hk,He) a1 a2 Ha; simpl in *; apply Comp; auto. unfold complement, eq_key, eq_key_elt; repeat red. intuition eauto. intros (k,e) (k',e'); unfold eq_key, uncurry; simpl; auto. rewrite <- NoDupA_altdef; auto. intros (k,e). - rewrite 2 InA_rev, <- 2 elements_mapsto_iff, 2 find_mapsto_iff, H; - auto with *. + rewrite 2 InA_rev, <- 2 elements_mapsto_iff, 2 find_mapsto_iff, H. + auto with crelations. Qed. Lemma fold_Equal2 : forall m1 m2 i j, Equal m1 m2 -> eqA i j -> @@ -1125,10 +1128,13 @@ Module WProperties_fun (E:DecidableType)(M:WSfun E). Proof. intros. rewrite 2 fold_spec_right. - assert (NoDupA eqk (rev (elements m1))) by (auto with * ). - assert (NoDupA eqk (rev (elements m2))) by (auto with * ). - apply fold_right_equivlistA_restr2 with (R:=complement eqk)(eqA:=eqke) - ; auto with *. + assert (NoDupA eqk (rev (elements m1))) by auto with map typeclass_instances. + assert (NoDupA eqk (rev (elements m2))) by auto with map typeclass_instances. + apply fold_right_equivlistA_restr2 with (R:=complement eqk)(eqA:=eqke). + auto with typeclass_instances. + 1, 10: auto. + 2: auto with crelations. + 4, 5: auto with map. - intros (k1,e1) (k2,e2) (Hk,He) a1 a2 Ha; simpl in *; apply Comp; auto. - unfold complement, eq_key, eq_key_elt; repeat red. intuition eauto. - intros (k,e) (k',e') z z' h h'; unfold eq_key, uncurry;simpl; auto. @@ -1136,8 +1142,8 @@ Module WProperties_fun (E:DecidableType)(M:WSfun E). auto. - rewrite <- NoDupA_altdef; auto. - intros (k,e). - rewrite 2 InA_rev, <- 2 elements_mapsto_iff, 2 find_mapsto_iff, H; - auto with *. + rewrite 2 InA_rev, <- 2 elements_mapsto_iff, 2 find_mapsto_iff, H. + auto with crelations. Qed. @@ -1149,18 +1155,22 @@ Module WProperties_fun (E:DecidableType)(M:WSfun E). set (f':=uncurry f). change (f k e (fold_right f' i (rev (elements m1)))) with (f' (k,e) (fold_right f' i (rev (elements m1)))). - assert (NoDupA eqk (rev (elements m1))) by (auto with *). - assert (NoDupA eqk (rev (elements m2))) by (auto with *). + assert (NoDupA eqk (rev (elements m1))) by auto with map typeclass_instances. + assert (NoDupA eqk (rev (elements m2))) by auto with map typeclass_instances. apply fold_right_add_restr with - (R:=complement eqk)(eqA:=eqke)(eqB:=eqA); auto with *. + (R:=complement eqk)(eqA:=eqke)(eqB:=eqA). + auto with typeclass_instances. + auto. + 2: auto with crelations. + 4, 5: auto with map. intros (k1,e1) (k2,e2) (Hk,He) a a' Ha; unfold f'; simpl in *. apply Comp; auto. unfold complement, eq_key_elt, eq_key; repeat red; intuition eauto. unfold f'; intros (k1,e1) (k2,e2); unfold eq_key, uncurry; simpl; auto. rewrite <- NoDupA_altdef; auto. - rewrite InA_rev, <- elements_mapsto_iff by (auto with *). firstorder. + rewrite InA_rev, <- elements_mapsto_iff. firstorder. intros (a,b). rewrite InA_cons, 2 InA_rev, <- 2 elements_mapsto_iff, - 2 find_mapsto_iff by (auto with *). + 2 find_mapsto_iff. unfold eq_key_elt; simpl. rewrite H0. rewrite add_o. @@ -1791,7 +1801,7 @@ Module OrdProperties (M:S). Lemma sort_equivlistA_eqlistA : forall l l' : list (key*elt), sort ltk l -> sort ltk l' -> equivlistA eqke l l' -> eqlistA eqke l l'. Proof. - apply SortA_equivlistA_eqlistA; eauto with *. + apply SortA_equivlistA_eqlistA; auto with typeclass_instances. Qed. Ltac clean_eauto := unfold O.eqke, O.ltk; simpl; intuition; eauto. @@ -1842,7 +1852,9 @@ Module OrdProperties (M:S). elements m = elements_lt p m ++ elements_ge p m. Proof. unfold elements_lt, elements_ge, leb; intros. - apply filter_split with (eqA:=eqk) (ltA:=ltk); eauto with *. + apply filter_split with (eqA:=eqk) (ltA:=ltk). + 1-3: auto with typeclass_instances. + 2: auto with map. intros; destruct x; destruct y; destruct p. rewrite gtb_1 in H; unfold O.ltk in H; simpl in *. assert (~ltk (t1,e0) (k,e1)). @@ -1856,14 +1868,14 @@ Module OrdProperties (M:S). (elements_lt (x,e) m ++ (x,e):: elements_ge (x,e) m). Proof. intros; unfold elements_lt, elements_ge. - apply sort_equivlistA_eqlistA; auto with *. - apply (@SortA_app _ eqke); auto with *. - apply (@filter_sort _ eqke); auto with *; clean_eauto. + apply sort_equivlistA_eqlistA. auto with map. + apply (@SortA_app _ eqke). auto with typeclass_instances. + apply (@filter_sort _ eqke). 1-3: auto with typeclass_instances. auto with map. constructor; auto with map. - apply (@filter_sort _ eqke); auto with *; clean_eauto. - rewrite (@InfA_alt _ eqke); auto with *; try (clean_eauto; fail). + apply (@filter_sort _ eqke). 1-3: auto with typeclass_instances. auto with map. + rewrite (@InfA_alt _ eqke). 2-4: auto with typeclass_instances. intros. - rewrite filter_InA in H1; auto with *; destruct H1. + rewrite filter_InA in H1 by auto with map. destruct H1. rewrite leb_1 in H2. destruct y; unfold O.ltk in *; simpl in *. rewrite <- elements_mapsto_iff in H1. @@ -1871,22 +1883,22 @@ Module OrdProperties (M:S). contradict H. exists e0; apply MapsTo_1 with t0; auto with ordered_type. ME.order. - apply (@filter_sort _ eqke); auto with *; clean_eauto. + apply (@filter_sort _ eqke). 1-3: auto with typeclass_instances. auto with map. intros. - rewrite filter_InA in H1; auto with *; destruct H1. + rewrite filter_InA in H1 by auto with map. destruct H1. rewrite gtb_1 in H3. destruct y; destruct x0; unfold O.ltk in *; simpl in *. inversion_clear H2. red in H4; simpl in *; destruct H4. ME.order. - rewrite filter_InA in H4; auto with *; destruct H4. + rewrite filter_InA in H4 by auto with map. destruct H4. rewrite leb_1 in H4. unfold O.ltk in *; simpl in *; ME.order. red; intros a; destruct a. rewrite InA_app_iff, InA_cons, 2 filter_InA, <-2 elements_mapsto_iff, leb_1, gtb_1, find_mapsto_iff, (H0 t0), <- find_mapsto_iff, - add_mapsto_iff by (auto with *). + add_mapsto_iff by auto with map. unfold O.eqke, O.ltk; simpl. destruct (E.compare t0 x); intuition; try fold (~E.eq x t0); auto with ordered_type. - elim H; exists e0; apply MapsTo_1 with t0; auto. @@ -1898,8 +1910,8 @@ Module OrdProperties (M:S). eqlistA eqke (elements m') (elements m ++ (x,e)::nil). Proof. intros. - apply sort_equivlistA_eqlistA; auto with *. - apply (@SortA_app _ eqke); auto with *. + apply sort_equivlistA_eqlistA. auto with map. + apply (@SortA_app _ eqke). auto with typeclass_instances. auto with map. auto. intros. inversion_clear H2. destruct x0; destruct y. @@ -1911,7 +1923,7 @@ Module OrdProperties (M:S). red; intros a; destruct a. rewrite InA_app_iff, InA_cons, InA_nil, <- 2 elements_mapsto_iff, find_mapsto_iff, (H0 t0), <- find_mapsto_iff, - add_mapsto_iff by (auto with *). + add_mapsto_iff. unfold O.eqke; simpl. intuition. destruct (E.eq_dec x t0) as [Heq|Hneq]; auto. exfalso. @@ -1926,9 +1938,9 @@ Module OrdProperties (M:S). eqlistA eqke (elements m') ((x,e)::elements m). Proof. intros. - apply sort_equivlistA_eqlistA; auto with *. + apply sort_equivlistA_eqlistA. auto with map. change (sort ltk (((x,e)::nil) ++ elements m)). - apply (@SortA_app _ eqke); auto with *. + apply (@SortA_app _ eqke). auto with typeclass_instances. auto. auto with map. intros. inversion_clear H1. destruct y; destruct x0. @@ -1940,7 +1952,7 @@ Module OrdProperties (M:S). red; intros a; destruct a. rewrite InA_cons, <- 2 elements_mapsto_iff, find_mapsto_iff, (H0 t0), <- find_mapsto_iff, - add_mapsto_iff by (auto with *). + add_mapsto_iff. unfold O.eqke; simpl. intuition. destruct (E.eq_dec x t0) as [Heq|Hneq]; auto. exfalso. @@ -1954,7 +1966,7 @@ Module OrdProperties (M:S). Equal m m' -> eqlistA eqke (elements m) (elements m'). Proof. intros. - apply sort_equivlistA_eqlistA; auto with *. + apply sort_equivlistA_eqlistA. 1-2: auto with map. red; intros. destruct x; do 2 rewrite <- elements_mapsto_iff. do 2 rewrite find_mapsto_iff; rewrite H; split; auto. @@ -2056,7 +2068,7 @@ Module OrdProperties (M:S). inversion_clear H1 as [? ? H2|? ? H2]. red in H2; destruct H2; simpl in *; ME.order. inversion_clear H4. rename H1 into H3. - rewrite (@InfA_alt _ eqke) in H3; eauto with *. + rewrite (@InfA_alt _ eqke) in H3 by auto with typeclass_instances. apply (H3 (y,x0)); auto. Qed. diff --git a/theories/FSets/FMapPositive.v b/theories/FSets/FMapPositive.v index e9cb0a6aa7..c3c6c96997 100644 --- a/theories/FSets/FMapPositive.v +++ b/theories/FSets/FMapPositive.v @@ -679,7 +679,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. simpl; auto. destruct o; simpl; intros. (* Some *) - apply (SortA_app (eqA:=eq_key_elt)); auto with *. + apply (SortA_app (eqA:=eq_key_elt)). 1-2: auto with typeclass_instances. constructor; auto. apply In_InfA; intros. destruct y0. @@ -698,7 +698,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. eapply xelements_bits_lt_1; eauto. eapply xelements_bits_lt_2; eauto. (* None *) - apply (SortA_app (eqA:=eq_key_elt)); auto with *. + apply (SortA_app (eqA:=eq_key_elt)). auto with typeclass_instances. 1-2: auto. intros x0 y0. do 2 rewrite InA_alt. intros (y1,(Hy1,H)) (y2,(Hy2,H0)). diff --git a/theories/FSets/FSetBridge.v b/theories/FSets/FSetBridge.v index d267991c3c..73021a84a3 100644 --- a/theories/FSets/FSetBridge.v +++ b/theories/FSets/FSetBridge.v @@ -772,7 +772,7 @@ Module NodepOfDep (M: Sdep) <: S with Module E := M.E. generalize C; unfold compat_bool, Proper, respectful; intros; apply (f_equal negb); auto. simpl; unfold Equal; intuition. - apply filter_3; firstorder. + apply filter_3; firstorder with bool. elim (H2 a); intros. assert (In a s). eapply filter_1; eauto. diff --git a/theories/FSets/FSetCompat.v b/theories/FSets/FSetCompat.v index 4edeaee72e..bff999042b 100644 --- a/theories/FSets/FSetCompat.v +++ b/theories/FSets/FSetCompat.v @@ -381,22 +381,22 @@ Module Update_Sets Instance lt_strorder : StrictOrder lt. Proof. split. - intros x Hx. apply (M.lt_not_eq Hx); auto with *. + intros x Hx. apply (M.lt_not_eq Hx). auto with crelations. exact M.lt_trans. Qed. Instance lt_compat : Proper (eq==>eq==>iff) lt. Proof. - apply proper_sym_impl_iff_2; auto with *. + apply proper_sym_impl_iff_2. 1-2: auto with crelations. intros s s' Hs u u' Hu H. assert (H0 : lt s' u). destruct (M.compare s' u) as [H'|H'|H']; auto. - elim (M.lt_not_eq H). transitivity s'; auto with *. + elim (M.lt_not_eq H). transitivity s'; auto. elim (M.lt_not_eq (M.lt_trans H H')); auto. destruct (M.compare s' u') as [H'|H'|H']; auto. elim (M.lt_not_eq H). - transitivity u'; auto with *. transitivity s'; auto with *. - elim (M.lt_not_eq (M.lt_trans H' H0)); auto with *. + transitivity u'. 2: auto with crelations. transitivity s'; auto. + elim (M.lt_not_eq (M.lt_trans H' H0)); auto with crelations. Qed. Definition compare s s' := diff --git a/theories/FSets/FSetEqProperties.v b/theories/FSets/FSetEqProperties.v index 1542660ab7..ac08351ad9 100644 --- a/theories/FSets/FSetEqProperties.v +++ b/theories/FSets/FSetEqProperties.v @@ -924,7 +924,7 @@ transitivity (f x (fold f s0 i)). apply fold_add with (eqA:=eqA); auto with set. transitivity (g x (fold f s0 i)); auto with set. transitivity (g x (fold g s0 i)); auto with set. -apply gc; auto with *. +apply gc; auto with set. symmetry; apply fold_add with (eqA:=eqA); auto. do 2 rewrite fold_empty; reflexivity. Qed. diff --git a/theories/FSets/FSetProperties.v b/theories/FSets/FSetProperties.v index 88d12fc387..98b445580b 100644 --- a/theories/FSets/FSetProperties.v +++ b/theories/FSets/FSetProperties.v @@ -365,7 +365,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). assert (Pstep' : forall x a s' s'', InA x l -> ~In x s' -> Add x s' s'' -> P s' a -> P s'' (f x a)). intros; eapply Pstep; eauto. - rewrite elements_iff, <- InA_rev; auto with *. + rewrite elements_iff, <- InA_rev; auto. assert (Hdup : NoDup l) by (unfold l; eauto using elements_3w, NoDupA_rev with *). assert (Hsame : forall x, In x s <-> InA x l) by @@ -435,7 +435,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). intros A B R f g i j s Rempty Rstep. rewrite 2 fold_spec_right. set (l:=rev (elements s)). assert (Rstep' : forall x a b, InA x l -> R a b -> R (f x a) (g x b)) by - (intros; apply Rstep; auto; rewrite elements_iff, <- InA_rev; auto with *). + (intros; apply Rstep; auto; rewrite elements_iff, <- InA_rev; auto). clearbody l; clear Rstep s. induction l; simpl; auto. Qed. @@ -487,7 +487,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). fold f s i = fold_right f i l. Proof. intros; exists (rev (elements s)); split. - apply NoDupA_rev; auto with *. + apply NoDupA_rev. auto with typeclass_instances. auto with set. split; intros. rewrite elements_iff; do 2 rewrite InA_alt. split; destruct 1; generalize (In_rev (elements s) x0); exists x0; intuition. @@ -521,7 +521,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). intros; destruct (fold_0 s i f) as (l,(Hl, (Hl1, Hl2))); destruct (fold_0 s' i f) as (l',(Hl', (Hl'1, Hl'2))). rewrite Hl2; rewrite Hl'2; clear Hl2 Hl'2. - apply fold_right_add with (eqA:=E.eq)(eqB:=eqA); auto with *. + apply fold_right_add with (eqA:=E.eq)(eqB:=eqA). auto with typeclass_instances. 1-5: auto. rewrite <- Hl1; auto. intros a; rewrite InA_cons; rewrite <- Hl1; rewrite <- Hl'1; rewrite (H2 a); intuition. @@ -550,7 +550,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). intros. apply fold_rel with (R:=fun u v => eqA u (f x v)); intros. reflexivity. - transitivity (f x0 (f x b)); auto. apply Comp; auto with *. + transitivity (f x0 (f x b)); auto. apply Comp; auto. Qed. (** ** Fold is a morphism *) @@ -559,7 +559,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). eqA (fold f s i) (fold f s i'). Proof. intros. apply fold_rel with (R:=eqA); auto. - intros; apply Comp; auto with *. + intros; apply Comp; auto. Qed. Lemma fold_equal : @@ -914,7 +914,7 @@ Module OrdProperties (M:S). Lemma sort_equivlistA_eqlistA : forall l l' : list elt, sort E.lt l -> sort E.lt l' -> equivlistA E.eq l l' -> eqlistA E.eq l l'. Proof. - apply SortA_equivlistA_eqlistA; eauto with *. + apply SortA_equivlistA_eqlistA; auto with typeclass_instances. Qed. Definition gtb x y := match E.compare x y with GT _ => true | _ => false end. @@ -958,7 +958,7 @@ Module OrdProperties (M:S). elements s = elements_lt x s ++ elements_ge x s. Proof. unfold elements_lt, elements_ge, leb; intros. - eapply (@filter_split _ E.eq _ E.lt); auto with *. + eapply (@filter_split _ E.eq _ E.lt). 1-2: auto with typeclass_instances. 2: auto with set. intros. rewrite gtb_1 in H. assert (~E.lt y x). @@ -972,32 +972,32 @@ Module OrdProperties (M:S). Proof. intros; unfold elements_ge, elements_lt. apply sort_equivlistA_eqlistA; auto with set. - apply (@SortA_app _ E.eq); auto with *. - apply (@filter_sort _ E.eq); auto with *. + apply (@SortA_app _ E.eq). auto with typeclass_instances. + apply (@filter_sort _ E.eq). 1-3: auto with typeclass_instances. auto with set. constructor; auto. - apply (@filter_sort _ E.eq); auto with *. - rewrite ME.Inf_alt by (apply (@filter_sort _ E.eq); eauto with *). + apply (@filter_sort _ E.eq). 1-3: auto with typeclass_instances. auto with set. + rewrite ME.Inf_alt by (apply (@filter_sort _ E.eq); auto with set typeclass_instances). intros. - rewrite filter_InA in H1; auto with *; destruct H1. + rewrite filter_InA in H1 by auto with fset. destruct H1. rewrite leb_1 in H2. rewrite <- elements_iff in H1. assert (~E.eq x y). contradict H; rewrite H; auto. ME.order. intros. - rewrite filter_InA in H1; auto with *; destruct H1. + rewrite filter_InA in H1 by auto with fset. destruct H1. rewrite gtb_1 in H3. inversion_clear H2. ME.order. - rewrite filter_InA in H4; auto with *; destruct H4. + rewrite filter_InA in H4 by auto with fset. destruct H4. rewrite leb_1 in H4. ME.order. red; intros a. rewrite InA_app_iff, InA_cons, !filter_InA, <-elements_iff, - leb_1, gtb_1, (H0 a) by auto with *. + leb_1, gtb_1, (H0 a) by auto with fset. intuition. destruct (E.compare a x); intuition. - fold (~E.lt a x); auto with *. + fold (~E.lt a x); auto with ordered_type set. Qed. Definition Above x s := forall y, In y s -> E.lt y x. @@ -1008,15 +1008,15 @@ Module OrdProperties (M:S). eqlistA E.eq (elements s') (elements s ++ x::nil). Proof. intros. - apply sort_equivlistA_eqlistA; auto with *. - apply (@SortA_app _ E.eq); auto with *. + apply sort_equivlistA_eqlistA. auto with set. + apply (@SortA_app _ E.eq). auto with typeclass_instances. auto with set. auto. intros. inversion_clear H2. rewrite <- elements_iff in H1. apply ME.lt_eq with x; auto with ordered_type. inversion H3. red; intros a. - rewrite InA_app_iff, InA_cons, InA_nil by auto with *. + rewrite InA_app_iff, InA_cons, InA_nil. do 2 rewrite <- elements_iff; rewrite (H0 a); intuition. Qed. @@ -1025,9 +1025,9 @@ Module OrdProperties (M:S). eqlistA E.eq (elements s') (x::elements s). Proof. intros. - apply sort_equivlistA_eqlistA; auto with *. + apply sort_equivlistA_eqlistA. auto with set. change (sort E.lt ((x::nil) ++ elements s)). - apply (@SortA_app _ E.eq); auto with *. + apply (@SortA_app _ E.eq). auto with typeclass_instances. auto. auto with set. intros. inversion_clear H1. rewrite <- elements_iff in H2. diff --git a/theories/Init/Decimal.v b/theories/Init/Decimal.v index 10c3baa2cd..855db8bc3f 100644 --- a/theories/Init/Decimal.v +++ b/theories/Init/Decimal.v @@ -156,6 +156,37 @@ Definition nztail_int d := | Neg d => let (r, n) := nztail d in pair (Neg r) n end. +(** [del_head n d] removes [n] digits at beginning of [d] + or returns [zero] if [d] has less than [n] digits. *) + +Fixpoint del_head n d := + match n with + | O => d + | S n => + match d with + | Nil => zero + | D0 d | D1 d | D2 d | D3 d | D4 d | D5 d | D6 d | D7 d | D8 d | D9 d => + del_head n d + end + end. + +Definition del_head_int n d := + match d with + | Pos d => Pos (del_head n d) + | Neg d => Neg (del_head n d) + end. + +(** [del_tail n d] removes [n] digits at end of [d] + or returns [zero] if [d] has less than [n] digits. *) + +Fixpoint del_tail n d := rev (del_head n (rev d)). + +Definition del_tail_int n d := + match d with + | Pos d => Pos (del_tail n d) + | Neg d => Neg (del_tail n d) + end. + Module Little. (** Successor of little-endian numbers *) diff --git a/theories/Init/Prelude.v b/theories/Init/Prelude.v index 6126d9c37d..71ba3e645d 100644 --- a/theories/Init/Prelude.v +++ b/theories/Init/Prelude.v @@ -43,5 +43,5 @@ Numeral Notation nat Nat.of_uint Nat.to_uint : nat_scope (abstract after 5001). (* Printing/Parsing of bytes *) Export Byte.ByteSyntaxNotations. -(* Default substrings not considered by queries like SearchAbout *) +(* Default substrings not considered by queries like Search *) Add Search Blacklist "_subproof" "_subterm" "Private_". diff --git a/theories/Lists/List.v b/theories/Lists/List.v index 6a1554d102..f050f11170 100644 --- a/theories/Lists/List.v +++ b/theories/Lists/List.v @@ -1413,13 +1413,16 @@ End Fold_Right_Recursor. Lemma existsb_exists : forall l, existsb l = true <-> exists x, In x l /\ f x = true. Proof. - induction l; simpl; intuition. - inversion H. - firstorder. - destruct (orb_prop _ _ H1); firstorder. - firstorder. - subst. - rewrite H2; auto. + induction l as [ | a m IH ]; split; simpl. + - easy. + - intros [x [[]]]. + - rewrite orb_true_iff; intros [ H | H ]. + + exists a; auto. + + rewrite IH in H; destruct H as [ x [ Hxm Hfx ] ]. + exists x; auto. + - intros [ x [ [ Hax | Hxm ] Hfx ] ]. + + now rewrite Hax, Hfx. + + destruct IH as [ _ -> ]; eauto with bool. Qed. Lemma existsb_nth : forall l n d, n < length l -> @@ -2747,7 +2750,7 @@ Section Exists_Forall. Proof. split. - induction 1; firstorder; subst; auto. - - induction l; firstorder. + - induction l; firstorder auto with datatypes. Qed. Lemma Forall_nth l : diff --git a/theories/MSets/MSetPositive.v b/theories/MSets/MSetPositive.v index a15b533d3d..4f2f4256e2 100644 --- a/theories/MSets/MSetPositive.v +++ b/theories/MSets/MSetPositive.v @@ -771,7 +771,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. Proof. unfold Exists, In. intro f. induction s as [|l IHl o r IHr]; intros i; simpl. - firstorder. + firstorder with bool. rewrite <- 2orb_lazy_alt, 2orb_true_iff, <- andb_lazy_alt, andb_true_iff. rewrite IHl, IHr. clear IHl IHr. split. diff --git a/theories/Numbers/Cyclic/Abstract/NZCyclic.v b/theories/Numbers/Cyclic/Abstract/NZCyclic.v index 6af9572fff..7c5b43096a 100644 --- a/theories/Numbers/Cyclic/Abstract/NZCyclic.v +++ b/theories/Numbers/Cyclic/Abstract/NZCyclic.v @@ -60,7 +60,7 @@ Ltac zcongruence := repeat red; intros; zify; congruence. Instance eq_equiv : Equivalence eq. Proof. - split. 1-2: firstorder. + split. 1-2: firstorder auto with crelations. intros x y z; apply eq_trans. Qed. diff --git a/theories/Numbers/Cyclic/Int31/Cyclic31.v b/theories/Numbers/Cyclic/Int31/Cyclic31.v index 1c790a37a0..f6b2544b6e 100644 --- a/theories/Numbers/Cyclic/Int31/Cyclic31.v +++ b/theories/Numbers/Cyclic/Int31/Cyclic31.v @@ -2226,7 +2226,7 @@ Section Int31_Specs. < ([|iter312_sqrt n rec ih il j|] + 1) ^ 2. Proof. revert rec ih il j; elim n; unfold iter312_sqrt; fold iter312_sqrt; clear n. - intros rec ih il j Hi Hj Hij Hrec; apply sqrt312_step_correct; auto with zarith. + intros rec ih il j Hi Hj Hij Hrec; apply sqrt312_step_correct. 1-3: lia. intros; apply Hrec. 2: rewrite Z.pow_0_r. 1-3: lia. intros n Hrec rec ih il j Hi Hj Hij HHrec. apply sqrt312_step_correct; auto. diff --git a/theories/Numbers/Cyclic/Int63/Int63.v b/theories/Numbers/Cyclic/Int63/Int63.v index a8c645deb2..c4f738ac39 100644 --- a/theories/Numbers/Cyclic/Int63/Int63.v +++ b/theories/Numbers/Cyclic/Int63/Int63.v @@ -1316,9 +1316,8 @@ Lemma iter_sqrt_correct n rec i j: 0 < φ i -> 0 < φ j -> φ (iter_sqrt n rec i j) ^ 2 <= φ i < (φ (iter_sqrt n rec i j) + 1) ^ 2. Proof. revert rec i j; elim n; unfold iter_sqrt; fold iter_sqrt; clear n. - intros rec i j Hi Hj Hij H31 Hrec; apply sqrt_step_correct; auto with zarith. - intros; apply Hrec; auto with zarith. - rewrite Zpower_0_r; auto with zarith. + intros rec i j Hi Hj Hij H31 Hrec; apply sqrt_step_correct. 1-4: lia. + intros; apply Hrec; only 2: rewrite Zpower_0_r; auto with zarith. intros n Hrec rec i j Hi Hj Hij H31 HHrec. apply sqrt_step_correct; auto. intros j1 Hj1 Hjp1; apply Hrec; auto with zarith. @@ -1516,9 +1515,8 @@ Lemma iter2_sqrt_correct n rec ih il j: < (φ (iter2_sqrt n rec ih il j) + 1) ^ 2. Proof. revert rec ih il j; elim n; unfold iter2_sqrt; fold iter2_sqrt; clear n. - intros rec ih il j Hi Hj Hij Hrec; apply sqrt2_step_correct; auto with zarith. - intros; apply Hrec; auto with zarith. - rewrite Zpower_0_r; auto with zarith. + intros rec ih il j Hi Hj Hij Hrec; apply sqrt2_step_correct. 1-3: lia. + intros; apply Hrec; only 2: rewrite Zpower_0_r; auto with zarith. intros n Hrec rec ih il j Hi Hj Hij HHrec. apply sqrt2_step_correct; auto. intros j1 Hj1 Hjp1; apply Hrec; auto with zarith. diff --git a/theories/QArith/QArith_base.v b/theories/QArith/QArith_base.v index a7f338aec3..bd5225d9ef 100644 --- a/theories/QArith/QArith_base.v +++ b/theories/QArith/QArith_base.v @@ -44,13 +44,39 @@ Definition of_decimal (d:Decimal.decimal) : Q := end. Definition to_decimal (q:Q) : option Decimal.decimal := + (* choose between 123e-2 and 1.23, this is purely heuristic + and doesn't play any soundness role *) + let choose_exponent i ne := + let i := match i with Decimal.Pos i | Decimal.Neg i => i end in + let li := Decimal.nb_digits i in + let le := Decimal.nb_digits (Nat.to_uint ne) in + Nat.ltb (Nat.add li le) ne in + (* print 123 / 100 as 123e-2 *) + let decimal_exponent i ne := + let e := Z.to_int (Z.opp (Z.of_nat ne)) in + Decimal.DecimalExp i Decimal.Nil e in + (* print 123 / 100 as 1.23 *) + let decimal_dot i ne := + let ai := match i with Decimal.Pos i | Decimal.Neg i => i end in + let ni := Decimal.nb_digits ai in + if Nat.ltb ne ni then + let i := Decimal.del_tail_int ne i in + let f := Decimal.del_head (Nat.sub ni ne) ai in + Decimal.Decimal i f + else + let z := match i with + | Decimal.Pos _ => Decimal.Pos (Decimal.zero) + | Decimal.Neg _ => Decimal.Neg (Decimal.zero) end in + Decimal.Decimal z (Nat.iter (Nat.sub ne ni) Decimal.D0 ai) in let num := Z.to_int (Qnum q) in let (den, e_den) := Decimal.nztail (Pos.to_uint (Qden q)) in match den with | Decimal.D1 Decimal.Nil => - match Z.of_nat e_den with - | Z0 => Some (Decimal.Decimal num Decimal.Nil) - | e => Some (Decimal.DecimalExp num Decimal.Nil (Z.to_int (Z.opp e))) + match e_den with + | O => Some (Decimal.Decimal num Decimal.Nil) + | ne => + if choose_exponent num ne then Some (decimal_exponent num ne) + else Some (decimal_dot num ne) end | _ => None end. diff --git a/theories/Reals/Abstract/ConstructiveAbs.v b/theories/Reals/Abstract/ConstructiveAbs.v new file mode 100644 index 0000000000..d357ad2d54 --- /dev/null +++ b/theories/Reals/Abstract/ConstructiveAbs.v @@ -0,0 +1,950 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) +(************************************************************************) + +Require Import QArith. +Require Import Qabs. +Require Import ConstructiveReals. + +Local Open Scope ConstructiveReals. + +(** Properties of constructive absolute value (defined in + ConstructiveReals.CRabs). + Definition of minimum, maximum and their properties. *) + +Instance CRabs_morph + : forall {R : ConstructiveReals}, + CMorphisms.Proper + (CMorphisms.respectful (CReq R) (CReq R)) (CRabs R). +Proof. + intros R x y [H H0]. split. + - rewrite <- CRabs_def. split. + + apply (CRle_trans _ x). apply H. + pose proof (CRabs_def R x (CRabs R x)) as [_ H1]. + apply H1. apply CRle_refl. + + apply (CRle_trans _ (CRopp R x)). intro abs. + apply CRopp_lt_cancel in abs. contradiction. + pose proof (CRabs_def R x (CRabs R x)) as [_ H1]. + apply H1. apply CRle_refl. + - rewrite <- CRabs_def. split. + + apply (CRle_trans _ y). apply H0. + pose proof (CRabs_def R y (CRabs R y)) as [_ H1]. + apply H1. apply CRle_refl. + + apply (CRle_trans _ (CRopp R y)). intro abs. + apply CRopp_lt_cancel in abs. contradiction. + pose proof (CRabs_def R y (CRabs R y)) as [_ H1]. + apply H1. apply CRle_refl. +Qed. + +Add Parametric Morphism {R : ConstructiveReals} : (CRabs R) + with signature CReq R ==> CReq R + as CRabs_morph_prop. +Proof. + intros. apply CRabs_morph, H. +Qed. + +Lemma CRabs_right : forall {R : ConstructiveReals} (x : CRcarrier R), + 0 <= x -> CRabs R x == x. +Proof. + intros. split. + - pose proof (CRabs_def R x (CRabs R x)) as [_ H1]. + apply H1, CRle_refl. + - rewrite <- CRabs_def. split. apply CRle_refl. + apply (CRle_trans _ (CRzero R)). 2: exact H. + apply (CRle_trans _ (CRopp R (CRzero R))). + intro abs. apply CRopp_lt_cancel in abs. contradiction. + apply (CRplus_le_reg_l (CRzero R)). + apply (CRle_trans _ (CRzero R)). apply CRplus_opp_r. + apply CRplus_0_r. +Qed. + +Lemma CRabs_opp : forall {R : ConstructiveReals} (x : CRcarrier R), + CRabs R (- x) == CRabs R x. +Proof. + intros. split. + - rewrite <- CRabs_def. split. + + pose proof (CRabs_def R (CRopp R x) (CRabs R (CRopp R x))) as [_ H1]. + specialize (H1 (CRle_refl (CRabs R (CRopp R x)))) as [_ H1]. + apply (CRle_trans _ (CRopp R (CRopp R x))). + 2: exact H1. apply (CRopp_involutive x). + + pose proof (CRabs_def R (CRopp R x) (CRabs R (CRopp R x))) as [_ H1]. + apply H1, CRle_refl. + - rewrite <- CRabs_def. split. + + pose proof (CRabs_def R x (CRabs R x)) as [_ H1]. + apply H1, CRle_refl. + + apply (CRle_trans _ x). apply CRopp_involutive. + pose proof (CRabs_def R x (CRabs R x)) as [_ H1]. + apply H1, CRle_refl. +Qed. + +Lemma CRabs_minus_sym : forall {R : ConstructiveReals} (x y : CRcarrier R), + CRabs R (x - y) == CRabs R (y - x). +Proof. + intros R x y. setoid_replace (x - y) with (-(y-x)). + rewrite CRabs_opp. reflexivity. unfold CRminus. + rewrite CRopp_plus_distr, CRplus_comm, CRopp_involutive. + reflexivity. +Qed. + +Lemma CRabs_left : forall {R : ConstructiveReals} (x : CRcarrier R), + x <= 0 -> CRabs R x == - x. +Proof. + intros. rewrite <- CRabs_opp. apply CRabs_right. + rewrite <- CRopp_0. apply CRopp_ge_le_contravar, H. +Qed. + +Lemma CRabs_triang : forall {R : ConstructiveReals} (x y : CRcarrier R), + CRabs R (x + y) <= CRabs R x + CRabs R y. +Proof. + intros. rewrite <- CRabs_def. split. + - apply (CRle_trans _ (CRplus R (CRabs R x) y)). + apply CRplus_le_compat_r. + pose proof (CRabs_def R x (CRabs R x)) as [_ H1]. + apply H1, CRle_refl. + apply CRplus_le_compat_l. + pose proof (CRabs_def R y (CRabs R y)) as [_ H1]. + apply H1, CRle_refl. + - apply (CRle_trans _ (CRplus R (CRopp R x) (CRopp R y))). + apply CRopp_plus_distr. + apply (CRle_trans _ (CRplus R (CRabs R x) (CRopp R y))). + apply CRplus_le_compat_r. + pose proof (CRabs_def R x (CRabs R x)) as [_ H1]. + apply H1, CRle_refl. + apply CRplus_le_compat_l. + pose proof (CRabs_def R y (CRabs R y)) as [_ H1]. + apply H1, CRle_refl. +Qed. + +Lemma CRabs_le : forall {R : ConstructiveReals} (a b:CRcarrier R), + (-b <= a /\ a <= b) -> CRabs R a <= b. +Proof. + intros. pose proof (CRabs_def R a b) as [H0 _]. + apply H0. split. apply H. destruct H. + rewrite <- (CRopp_involutive b). + apply CRopp_ge_le_contravar. exact H. +Qed. + +Lemma CRabs_triang_inv : forall {R : ConstructiveReals} (x y : CRcarrier R), + CRabs R x - CRabs R y <= CRabs R (x - y). +Proof. + intros. apply (CRplus_le_reg_r (CRabs R y)). + unfold CRminus. rewrite CRplus_assoc, CRplus_opp_l. + rewrite CRplus_0_r. + apply (CRle_trans _ (CRabs R (x - y + y))). + setoid_replace (x - y + y) with x. apply CRle_refl. + unfold CRminus. rewrite CRplus_assoc, CRplus_opp_l. + rewrite CRplus_0_r. reflexivity. + apply CRabs_triang. +Qed. + +Lemma CRabs_triang_inv2 : forall {R : ConstructiveReals} (x y : CRcarrier R), + CRabs R (CRabs R x - CRabs R y) <= CRabs R (x - y). +Proof. + intros. apply CRabs_le. split. + 2: apply CRabs_triang_inv. + apply (CRplus_le_reg_r (CRabs R y)). + unfold CRminus. rewrite CRplus_assoc, CRplus_opp_l. + rewrite CRplus_0_r. fold (x - y). + rewrite CRplus_comm, CRabs_minus_sym. + apply (CRle_trans _ _ _ (CRabs_triang_inv y (y-x))). + setoid_replace (y - (y - x)) with x. apply CRle_refl. + unfold CRminus. rewrite CRopp_plus_distr, <- CRplus_assoc. + rewrite CRplus_opp_r, CRplus_0_l. apply CRopp_involutive. +Qed. + +Lemma CR_of_Q_abs : forall {R : ConstructiveReals} (q : Q), + CRabs R (CR_of_Q R q) == CR_of_Q R (Qabs q). +Proof. + intros. destruct (Qlt_le_dec 0 q). + - apply (CReq_trans _ (CR_of_Q R q)). + apply CRabs_right. apply (CRle_trans _ (CR_of_Q R 0)). + apply CR_of_Q_zero. apply CR_of_Q_le. apply Qlt_le_weak, q0. + apply CR_of_Q_morph. symmetry. apply Qabs_pos, Qlt_le_weak, q0. + - apply (CReq_trans _ (CR_of_Q R (-q))). + apply (CReq_trans _ (CRabs R (CRopp R (CR_of_Q R q)))). + apply CReq_sym, CRabs_opp. + 2: apply CR_of_Q_morph; symmetry; apply Qabs_neg, q0. + apply (CReq_trans _ (CRopp R (CR_of_Q R q))). + 2: apply CReq_sym, CR_of_Q_opp. + apply CRabs_right. apply (CRle_trans _ (CR_of_Q R 0)). + apply CR_of_Q_zero. + apply (CRle_trans _ (CR_of_Q R (-q))). apply CR_of_Q_le. + apply (Qplus_le_l _ _ q). ring_simplify. exact q0. + apply CR_of_Q_opp. +Qed. + +Lemma CRle_abs : forall {R : ConstructiveReals} (x : CRcarrier R), + x <= CRabs R x. +Proof. + intros. pose proof (CRabs_def R x (CRabs R x)) as [_ H]. + apply H, CRle_refl. +Qed. + +Lemma CRabs_pos : forall {R : ConstructiveReals} (x : CRcarrier R), + 0 <= CRabs R x. +Proof. + intros. intro abs. destruct (CRltLinear R). clear p. + specialize (s _ x _ abs). destruct s. + exact (CRle_abs x c). rewrite CRabs_left in abs. + rewrite <- CRopp_0 in abs. apply CRopp_lt_cancel in abs. + exact (CRlt_asym _ _ abs c). apply CRlt_asym, c. +Qed. + +Lemma CRabs_appart_0 : forall {R : ConstructiveReals} (x : CRcarrier R), + 0 < CRabs R x -> x ≶ 0. +Proof. + intros. destruct (CRltLinear R). clear p. + pose proof (s _ x _ H) as [pos|neg]. + right. exact pos. left. + destruct (CR_Q_dense R _ _ neg) as [q [H0 H1]]. + destruct (Qlt_le_dec 0 q). + - destruct (s (CR_of_Q R (-q)) x 0). + rewrite <- CR_of_Q_zero. apply CR_of_Q_lt. + apply (Qplus_lt_l _ _ q). ring_simplify. exact q0. + exfalso. pose proof (CRabs_def R x (CR_of_Q R q)) as [H2 _]. + apply H2. clear H2. split. apply CRlt_asym, H0. + 2: exact H1. rewrite <- Qopp_involutive, CR_of_Q_opp. + apply CRopp_ge_le_contravar, CRlt_asym, c. exact c. + - apply (CRlt_le_trans _ _ _ H0). + rewrite <- CR_of_Q_zero. apply CR_of_Q_le. exact q0. +Qed. + + +(* The proof by cases on the signs of x and y applies constructively, + because of the positivity hypotheses. *) +Lemma CRabs_mult : forall {R : ConstructiveReals} (x y : CRcarrier R), + CRabs R (x * y) == CRabs R x * CRabs R y. +Proof. + intro R. + assert (forall (x y : CRcarrier R), + x ≶ 0 + -> y ≶ 0 + -> CRabs R (x * y) == CRabs R x * CRabs R y) as prep. + { intros. destruct H, H0. + + rewrite CRabs_right, CRabs_left, CRabs_left. + rewrite <- CRopp_mult_distr_l, CRopp_mult_distr_r, CRopp_involutive. + reflexivity. + apply CRlt_asym, c0. apply CRlt_asym, c. + setoid_replace (x*y) with (- x * - y). + apply CRlt_asym, CRmult_lt_0_compat. + rewrite <- CRopp_0. apply CRopp_gt_lt_contravar, c. + rewrite <- CRopp_0. apply CRopp_gt_lt_contravar, c0. + rewrite <- CRopp_mult_distr_l, CRopp_mult_distr_r, CRopp_involutive. + reflexivity. + + rewrite CRabs_left, CRabs_left, CRabs_right. + rewrite <- CRopp_mult_distr_l. reflexivity. + apply CRlt_asym, c0. apply CRlt_asym, c. + rewrite <- (CRmult_0_l y). + apply CRmult_le_compat_r_half. exact c0. + apply CRlt_asym, c. + + rewrite CRabs_left, CRabs_right, CRabs_left. + rewrite <- CRopp_mult_distr_r. reflexivity. + apply CRlt_asym, c0. apply CRlt_asym, c. + rewrite <- (CRmult_0_r x). + apply CRmult_le_compat_l_half. + exact c. apply CRlt_asym, c0. + + rewrite CRabs_right, CRabs_right, CRabs_right. reflexivity. + apply CRlt_asym, c0. apply CRlt_asym, c. + apply CRlt_asym, CRmult_lt_0_compat; assumption. } + split. + - intro abs. + assert (0 < CRabs R x * CRabs R y). + { apply (CRle_lt_trans _ (CRabs R (x*y))). + apply CRabs_pos. exact abs. } + pose proof (CRmult_pos_appart_zero _ _ H). + rewrite CRmult_comm in H. + apply CRmult_pos_appart_zero in H. + destruct H. 2: apply (CRabs_pos y c). + destruct H0. 2: apply (CRabs_pos x c0). + apply CRabs_appart_0 in c. + apply CRabs_appart_0 in c0. + rewrite (prep x y) in abs. + exact (CRlt_asym _ _ abs abs). exact c0. exact c. + - intro abs. + assert (0 < CRabs R (x * y)). + { apply (CRle_lt_trans _ (CRabs R x * CRabs R y)). + rewrite <- (CRmult_0_l (CRabs R y)). + apply CRmult_le_compat_r. + apply CRabs_pos. apply CRabs_pos. exact abs. } + apply CRabs_appart_0 in H. destruct H. + + apply CRopp_gt_lt_contravar in c. + rewrite CRopp_0, CRopp_mult_distr_l in c. + pose proof (CRmult_pos_appart_zero _ _ c). + rewrite CRmult_comm in c. + apply CRmult_pos_appart_zero in c. + rewrite (prep x y) in abs. + exact (CRlt_asym _ _ abs abs). + destruct H. left. apply CRopp_gt_lt_contravar in c0. + rewrite CRopp_involutive, CRopp_0 in c0. exact c0. + right. apply CRopp_gt_lt_contravar in c0. + rewrite CRopp_involutive, CRopp_0 in c0. exact c0. + destruct c. right. exact c. left. exact c. + + pose proof (CRmult_pos_appart_zero _ _ c). + rewrite CRmult_comm in c. + apply CRmult_pos_appart_zero in c. + rewrite (prep x y) in abs. + exact (CRlt_asym _ _ abs abs). + destruct H. right. exact c0. left. exact c0. + destruct c. right. exact c. left. exact c. +Qed. + +Lemma CRabs_lt : forall {R : ConstructiveReals} (x y : CRcarrier R), + CRabs _ x < y -> prod (x < y) (-x < y). +Proof. + split. + - apply (CRle_lt_trans _ _ _ (CRle_abs x)), H. + - apply (CRle_lt_trans _ _ _ (CRle_abs (-x))). + rewrite CRabs_opp. exact H. +Qed. + +Lemma CRabs_def1 : forall {R : ConstructiveReals} (x y : CRcarrier R), + x < y -> -x < y -> CRabs _ x < y. +Proof. + intros. destruct (CRltLinear R), p. + destruct (s x (CRabs R x) y H). 2: exact c0. + rewrite CRabs_left. exact H0. intro abs. + rewrite CRabs_right in c0. exact (CRlt_asym x x c0 c0). + apply CRlt_asym, abs. +Qed. + +Lemma CRabs_def2 : forall {R : ConstructiveReals} (x a:CRcarrier R), + CRabs _ x <= a -> (x <= a) /\ (- a <= x). +Proof. + split. + - exact (CRle_trans _ _ _ (CRle_abs _) H). + - rewrite <- (CRopp_involutive x). + apply CRopp_ge_le_contravar. + rewrite <- CRabs_opp in H. + exact (CRle_trans _ _ _ (CRle_abs _) H). +Qed. + + +(* Minimum *) + +Definition CRmin {R : ConstructiveReals} (x y : CRcarrier R) : CRcarrier R + := (x + y - CRabs _ (y - x)) * CR_of_Q _ (1#2). + +Lemma CRmin_lt_r : forall {R : ConstructiveReals} (x y : CRcarrier R), + CRmin x y < y -> CRmin x y == x. +Proof. + intros. unfold CRmin. unfold CRmin in H. + apply (CRmult_eq_reg_r (CR_of_Q R 2)). + left; apply CR_of_Q_pos; reflexivity. + rewrite CRmult_assoc, <- CR_of_Q_mult. + setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. + rewrite CR_of_Q_one, CRmult_1_r. + rewrite (CR_of_Q_plus R 1 1), CR_of_Q_one, CRmult_plus_distr_l, CRmult_1_r. + rewrite CRabs_right. unfold CRminus. + rewrite CRopp_plus_distr, CRplus_assoc, <- (CRplus_assoc y). + rewrite CRplus_opp_r, CRplus_0_l, CRopp_involutive. reflexivity. + apply (CRmult_lt_compat_r (CR_of_Q R 2)) in H. + 2: apply CR_of_Q_pos; reflexivity. + rewrite CRmult_assoc, <- CR_of_Q_mult in H. + setoid_replace ((1 # 2) * 2)%Q with 1%Q in H. 2: reflexivity. + rewrite CR_of_Q_one, CRmult_1_r in H. + rewrite CRmult_comm, (CR_of_Q_plus R 1 1), CR_of_Q_one, CRmult_plus_distr_r, + CRmult_1_l in H. + intro abs. rewrite CRabs_left in H. + unfold CRminus in H. + rewrite CRopp_involutive, CRplus_comm in H. + rewrite CRplus_assoc, <- (CRplus_assoc (-x)), CRplus_opp_l in H. + rewrite CRplus_0_l in H. exact (CRlt_asym _ _ H H). + apply CRlt_asym, abs. +Qed. + +Add Parametric Morphism {R : ConstructiveReals} : CRmin + with signature (CReq R) ==> (CReq R) ==> (CReq R) + as CRmin_morph. +Proof. + intros. unfold CRmin. + apply CRmult_morph. 2: reflexivity. + unfold CRminus. + rewrite H, H0. reflexivity. +Qed. + +Instance CRmin_morphT + : forall {R : ConstructiveReals}, + CMorphisms.Proper + (CMorphisms.respectful (CReq R) (CMorphisms.respectful (CReq R) (CReq R))) (@CRmin R). +Proof. + intros R x y H z t H0. + rewrite H, H0. reflexivity. +Qed. + +Lemma CRmin_l : forall {R : ConstructiveReals} (x y : CRcarrier R), + CRmin x y <= x. +Proof. + intros. unfold CRmin. + apply (CRmult_le_reg_r (CR_of_Q R 2)). + rewrite <- CR_of_Q_zero. apply CR_of_Q_lt; reflexivity. + rewrite CRmult_assoc, <- CR_of_Q_mult. + setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. + rewrite CR_of_Q_one, CRmult_1_r. + rewrite (CR_of_Q_plus _ 1 1), CRmult_plus_distr_l, CR_of_Q_one, CRmult_1_r. + unfold CRminus. rewrite CRplus_assoc. apply CRplus_le_compat_l. + apply (CRplus_le_reg_r (CRabs _ (y + - x)+ -x)). + rewrite CRplus_assoc, <- (CRplus_assoc (-CRabs _ (y + - x))). + rewrite CRplus_opp_l, CRplus_0_l. + rewrite (CRplus_comm x), CRplus_assoc, CRplus_opp_l, CRplus_0_r. + apply CRle_abs. +Qed. + +Lemma CRmin_r : forall {R : ConstructiveReals} (x y : CRcarrier R), + CRmin x y <= y. +Proof. + intros. unfold CRmin. + apply (CRmult_le_reg_r (CR_of_Q R 2)). + rewrite <- CR_of_Q_zero. apply CR_of_Q_lt; reflexivity. + rewrite CRmult_assoc, <- CR_of_Q_mult. + setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. + rewrite CR_of_Q_one, CRmult_1_r. + rewrite (CR_of_Q_plus _ 1 1), CRmult_plus_distr_l, CR_of_Q_one, CRmult_1_r. + rewrite (CRplus_comm x). + unfold CRminus. rewrite CRplus_assoc. apply CRplus_le_compat_l. + apply (CRplus_le_reg_l (-x)). + rewrite <- CRplus_assoc, CRplus_opp_l, CRplus_0_l. + rewrite <- (CRopp_involutive y), <- CRopp_plus_distr, <- CRopp_plus_distr. + apply CRopp_ge_le_contravar. rewrite CRabs_opp, CRplus_comm. + apply CRle_abs. +Qed. + +Lemma CRnegPartAbsMin : forall {R : ConstructiveReals} (x : CRcarrier R), + CRmin 0 x == (x - CRabs _ x) * (CR_of_Q _ (1#2)). +Proof. + intros. unfold CRmin. unfold CRminus. rewrite CRplus_0_l. + apply CRmult_morph. 2: reflexivity. rewrite CRopp_0, CRplus_0_r. reflexivity. +Qed. + +Lemma CRmin_sym : forall {R : ConstructiveReals} (x y : CRcarrier R), + CRmin x y == CRmin y x. +Proof. + intros. unfold CRmin. apply CRmult_morph. 2: reflexivity. + rewrite CRabs_minus_sym. unfold CRminus. + rewrite (CRplus_comm x y). reflexivity. +Qed. + +Lemma CRmin_mult : + forall {R : ConstructiveReals} (p q r : CRcarrier R), + 0 <= r -> CRmin (r * p) (r * q) == r * CRmin p q. +Proof. + intros R p q r H. unfold CRmin. + setoid_replace (r * q - r * p) with (r * (q - p)). + rewrite CRabs_mult. + rewrite (CRabs_right r). 2: exact H. + rewrite <- CRmult_assoc. apply CRmult_morph. 2: reflexivity. + unfold CRminus. rewrite CRopp_mult_distr_r. + do 2 rewrite <- CRmult_plus_distr_l. reflexivity. + unfold CRminus. rewrite CRopp_mult_distr_r. + rewrite <- CRmult_plus_distr_l. reflexivity. +Qed. + +Lemma CRmin_plus : forall {R : ConstructiveReals} (x y z : CRcarrier R), + x + CRmin y z == CRmin (x + y) (x + z). +Proof. + intros. unfold CRmin. + unfold CRminus. setoid_replace (x + z + - (x + y)) with (z-y). + apply (CRmult_eq_reg_r (CR_of_Q _ 2)). + left. rewrite <- CR_of_Q_zero. apply CR_of_Q_lt; reflexivity. + rewrite CRmult_plus_distr_r. + rewrite CRmult_assoc, <- CR_of_Q_mult. + setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. + rewrite CR_of_Q_one, CRmult_1_r. + rewrite CRmult_assoc, <- CR_of_Q_mult. + setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. + rewrite CR_of_Q_one, CRmult_1_r. + rewrite (CR_of_Q_plus _ 1 1), CRmult_plus_distr_l, CR_of_Q_one, CRmult_1_r. + do 3 rewrite (CRplus_assoc x). apply CRplus_morph. reflexivity. + do 2 rewrite <- CRplus_assoc. apply CRplus_morph. 2: reflexivity. + rewrite (CRplus_comm x). apply CRplus_assoc. + rewrite CRopp_plus_distr. rewrite <- CRplus_assoc. + apply CRplus_morph. 2: reflexivity. + rewrite CRplus_comm, <- CRplus_assoc, CRplus_opp_l. + apply CRplus_0_l. +Qed. + +Lemma CRmin_left : forall {R : ConstructiveReals} (x y : CRcarrier R), + x <= y -> CRmin x y == x. +Proof. + intros. unfold CRmin. + apply (CRmult_eq_reg_r (CR_of_Q R 2)). + left. rewrite <- CR_of_Q_zero. apply CR_of_Q_lt; reflexivity. + rewrite CRmult_assoc, <- CR_of_Q_mult. + setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. + rewrite CR_of_Q_one, CRmult_1_r. + rewrite (CR_of_Q_plus _ 1 1), CRmult_plus_distr_l, CR_of_Q_one, CRmult_1_r. + rewrite CRabs_right. unfold CRminus. rewrite CRopp_plus_distr. + rewrite CRplus_assoc. apply CRplus_morph. reflexivity. + rewrite <- CRplus_assoc, CRplus_opp_r, CRplus_0_l. apply CRopp_involutive. + rewrite <- (CRplus_opp_r x). apply CRplus_le_compat. + exact H. apply CRle_refl. +Qed. + +Lemma CRmin_right : forall {R : ConstructiveReals} (x y : CRcarrier R), + y <= x -> CRmin x y == y. +Proof. + intros. unfold CRmin. + apply (CRmult_eq_reg_r (CR_of_Q R 2)). + left. rewrite <- CR_of_Q_zero. apply CR_of_Q_lt; reflexivity. + rewrite CRmult_assoc, <- CR_of_Q_mult. + setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. + rewrite CR_of_Q_one, CRmult_1_r. + rewrite (CR_of_Q_plus _ 1 1), CRmult_plus_distr_l, CR_of_Q_one, CRmult_1_r. + rewrite CRabs_left. unfold CRminus. do 2 rewrite CRopp_plus_distr. + rewrite (CRplus_comm x y). + rewrite CRplus_assoc. apply CRplus_morph. reflexivity. + do 2 rewrite CRopp_involutive. + rewrite CRplus_comm, CRplus_assoc, CRplus_opp_l, CRplus_0_r. reflexivity. + rewrite <- (CRplus_opp_r x). apply CRplus_le_compat. + exact H. apply CRle_refl. +Qed. + +Lemma CRmin_lt : forall {R : ConstructiveReals} (x y z : CRcarrier R), + z < x -> z < y -> z < CRmin x y. +Proof. + intros. unfold CRmin. + apply (CRmult_lt_reg_r (CR_of_Q R 2)). + rewrite <- CR_of_Q_zero. apply CR_of_Q_lt; reflexivity. + rewrite CRmult_assoc, <- CR_of_Q_mult. + setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. + rewrite CR_of_Q_one, CRmult_1_r. + apply (CRplus_lt_reg_l _ (CRabs _ (y - x) - (z*CR_of_Q R 2))). + unfold CRminus. rewrite CRplus_assoc. rewrite CRplus_opp_l, CRplus_0_r. + rewrite (CRplus_comm (CRabs R (y + - x))). + rewrite (CRplus_comm (x+y)), CRplus_assoc. + rewrite <- (CRplus_assoc (CRabs R (y + - x))), CRplus_opp_r, CRplus_0_l. + rewrite <- (CRplus_comm (x+y)). + apply CRabs_def1. + - unfold CRminus. rewrite <- (CRplus_comm y), CRplus_assoc. + apply CRplus_lt_compat_l. + apply (CRplus_lt_reg_l R (-x)). + rewrite CRopp_mult_distr_l. + rewrite <- CRplus_assoc, CRplus_opp_l, CRplus_0_l. + rewrite (CR_of_Q_plus R 1 1), CR_of_Q_one, CRmult_plus_distr_l. + rewrite CRmult_1_r. apply CRplus_le_lt_compat. + apply CRlt_asym. + apply CRopp_gt_lt_contravar, H. + apply CRopp_gt_lt_contravar, H. + - rewrite CRopp_plus_distr, CRopp_involutive. + rewrite CRplus_comm, CRplus_assoc. + apply CRplus_lt_compat_l. + apply (CRplus_lt_reg_l R (-y)). + rewrite CRopp_mult_distr_l. + rewrite <- CRplus_assoc, CRplus_opp_l, CRplus_0_l. + rewrite (CR_of_Q_plus R 1 1), CR_of_Q_one, CRmult_plus_distr_l. + rewrite CRmult_1_r. apply CRplus_le_lt_compat. + apply CRlt_asym. + apply CRopp_gt_lt_contravar, H0. + apply CRopp_gt_lt_contravar, H0. +Qed. + +Lemma CRmin_contract : forall {R : ConstructiveReals} (x y a : CRcarrier R), + CRabs _ (CRmin x a - CRmin y a) <= CRabs _ (x - y). +Proof. + intros. unfold CRmin. + unfold CRminus. rewrite CRopp_mult_distr_l, <- CRmult_plus_distr_r. + rewrite (CRabs_morph + _ ((x - y + (CRabs _ (a - y) - CRabs _ (a - x))) * CR_of_Q R (1 # 2))). + rewrite CRabs_mult, (CRabs_right (CR_of_Q R (1 # 2))). + 2: rewrite <- CR_of_Q_zero; apply CR_of_Q_le; discriminate. + apply (CRle_trans _ + ((CRabs _ (x - y) * 1 + CRabs _ (x-y) * 1) + * CR_of_Q R (1 # 2))). + apply CRmult_le_compat_r. + rewrite <- CR_of_Q_zero. apply CR_of_Q_le. discriminate. + apply (CRle_trans + _ (CRabs _ (x - y) + CRabs _ (CRabs _ (a - y) - CRabs _ (a - x)))). + apply CRabs_triang. rewrite CRmult_1_r. apply CRplus_le_compat_l. + rewrite (CRabs_morph (x-y) ((a-y)-(a-x))). + apply CRabs_triang_inv2. + unfold CRminus. rewrite (CRplus_comm (a + - y)). + rewrite <- CRplus_assoc. apply CRplus_morph. 2: reflexivity. + rewrite CRplus_comm, CRopp_plus_distr, <- CRplus_assoc. + rewrite CRplus_opp_r, CRopp_involutive, CRplus_0_l. + reflexivity. + rewrite <- CRmult_plus_distr_l, <- CR_of_Q_one. + rewrite <- (CR_of_Q_plus R 1 1). + rewrite CRmult_assoc, <- CR_of_Q_mult. + setoid_replace ((1 + 1) * (1 # 2))%Q with 1%Q. 2: reflexivity. + rewrite CR_of_Q_one, CRmult_1_r. apply CRle_refl. + unfold CRminus. apply CRmult_morph. 2: reflexivity. + do 4 rewrite CRplus_assoc. apply CRplus_morph. reflexivity. + rewrite <- CRplus_assoc. rewrite CRplus_comm, CRopp_plus_distr. + rewrite CRplus_assoc. apply CRplus_morph. reflexivity. + rewrite CRopp_plus_distr. rewrite (CRplus_comm (-a)). + rewrite CRplus_assoc, <- (CRplus_assoc (-a)), CRplus_opp_l. + rewrite CRplus_0_l, CRopp_involutive. reflexivity. +Qed. + +Lemma CRmin_glb : forall {R : ConstructiveReals} (x y z:CRcarrier R), + z <= x -> z <= y -> z <= CRmin x y. +Proof. + intros. unfold CRmin. + apply (CRmult_le_reg_r (CR_of_Q R 2)). + rewrite <- CR_of_Q_zero. apply CR_of_Q_lt; reflexivity. + rewrite CRmult_assoc, <- CR_of_Q_mult. + setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. + rewrite CR_of_Q_one, CRmult_1_r. + apply (CRplus_le_reg_l (CRabs _ (y-x) - (z*CR_of_Q R 2))). + unfold CRminus. rewrite CRplus_assoc, CRplus_opp_l, CRplus_0_r. + rewrite (CRplus_comm (CRabs R (y + - x) + - (z * CR_of_Q R 2))). + rewrite CRplus_assoc, <- (CRplus_assoc (- CRabs R (y + - x))). + rewrite CRplus_opp_l, CRplus_0_l. + apply CRabs_le. split. + - do 2 rewrite CRopp_plus_distr. + rewrite CRopp_involutive, (CRplus_comm y), CRplus_assoc. + apply CRplus_le_compat_l, (CRplus_le_reg_l y). + rewrite <- CRplus_assoc, CRplus_opp_r, CRplus_0_l. + rewrite (CR_of_Q_plus R 1 1), CR_of_Q_one, CRmult_plus_distr_l. + rewrite CRmult_1_r. apply CRplus_le_compat; exact H0. + - rewrite (CRplus_comm x), CRplus_assoc. apply CRplus_le_compat_l. + apply (CRplus_le_reg_l (-x)). + rewrite <- CRplus_assoc, CRplus_opp_l, CRplus_0_l. + rewrite CRopp_mult_distr_l. + rewrite (CR_of_Q_plus R 1 1), CR_of_Q_one, CRmult_plus_distr_l. + rewrite CRmult_1_r. + apply CRplus_le_compat; apply CRopp_ge_le_contravar; exact H. +Qed. + +Lemma CRmin_assoc : forall {R : ConstructiveReals} (a b c : CRcarrier R), + CRmin a (CRmin b c) == CRmin (CRmin a b) c. +Proof. + split. + - apply CRmin_glb. + + apply (CRle_trans _ (CRmin a b)). + apply CRmin_l. apply CRmin_l. + + apply CRmin_glb. + apply (CRle_trans _ (CRmin a b)). + apply CRmin_l. apply CRmin_r. apply CRmin_r. + - apply CRmin_glb. + + apply CRmin_glb. apply CRmin_l. + apply (CRle_trans _ (CRmin b c)). + apply CRmin_r. apply CRmin_l. + + apply (CRle_trans _ (CRmin b c)). + apply CRmin_r. apply CRmin_r. +Qed. + +Lemma CRlt_min : forall {R : ConstructiveReals} (x y z : CRcarrier R), + z < CRmin x y -> prod (z < x) (z < y). +Proof. + intros. destruct (CR_Q_dense R _ _ H) as [q qmaj]. + destruct qmaj. + split. + - apply (CRlt_le_trans _ (CR_of_Q R q) _ c). + intro abs. apply (CRlt_asym _ _ c0). + apply (CRle_lt_trans _ x). apply CRmin_l. exact abs. + - apply (CRlt_le_trans _ (CR_of_Q R q) _ c). + intro abs. apply (CRlt_asym _ _ c0). + apply (CRle_lt_trans _ y). apply CRmin_r. exact abs. +Qed. + + + +(* Maximum *) + +Definition CRmax {R : ConstructiveReals} (x y : CRcarrier R) : CRcarrier R + := (x + y + CRabs _ (y - x)) * CR_of_Q _ (1#2). + +Add Parametric Morphism {R : ConstructiveReals} : CRmax + with signature (CReq R) ==> (CReq R) ==> (CReq R) + as CRmax_morph. +Proof. + intros. unfold CRmax. + apply CRmult_morph. 2: reflexivity. unfold CRminus. + rewrite H, H0. reflexivity. +Qed. + +Instance CRmax_morphT + : forall {R : ConstructiveReals}, + CMorphisms.Proper + (CMorphisms.respectful (CReq R) (CMorphisms.respectful (CReq R) (CReq R))) (@CRmax R). +Proof. + intros R x y H z t H0. + rewrite H, H0. reflexivity. +Qed. + +Lemma CRmax_lub : forall {R : ConstructiveReals} (x y z:CRcarrier R), + x <= z -> y <= z -> CRmax x y <= z. +Proof. + intros. unfold CRmax. + apply (CRmult_le_reg_r (CR_of_Q _ 2)). rewrite <- CR_of_Q_zero. + apply CR_of_Q_lt; reflexivity. + rewrite CRmult_assoc, <- CR_of_Q_mult. + setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. + rewrite CR_of_Q_one, CRmult_1_r. + apply (CRplus_le_reg_l (-x-y)). + rewrite <- CRplus_assoc. unfold CRminus. + rewrite <- CRopp_plus_distr, CRplus_opp_l, CRplus_0_l. + apply CRabs_le. split. + - repeat rewrite CRopp_plus_distr. + do 2 rewrite CRopp_involutive. + rewrite (CRplus_comm x), CRplus_assoc. apply CRplus_le_compat_l. + apply (CRplus_le_reg_l (-x)). + rewrite <- CRplus_assoc, CRplus_opp_l, CRplus_0_l. + rewrite (CR_of_Q_plus _ 1 1), CRmult_plus_distr_l, CR_of_Q_one, CRmult_1_r. + rewrite CRopp_plus_distr. + apply CRplus_le_compat; apply CRopp_ge_le_contravar; assumption. + - rewrite (CRplus_comm y), CRopp_plus_distr, CRplus_assoc. + apply CRplus_le_compat_l. + apply (CRplus_le_reg_l y). + rewrite <- CRplus_assoc, CRplus_opp_r, CRplus_0_l. + rewrite (CR_of_Q_plus _ 1 1), CRmult_plus_distr_l, CR_of_Q_one, CRmult_1_r. + apply CRplus_le_compat; assumption. +Qed. + +Lemma CRmax_l : forall {R : ConstructiveReals} (x y : CRcarrier R), + x <= CRmax x y. +Proof. + intros. unfold CRmax. + apply (CRmult_le_reg_r (CR_of_Q R 2)). rewrite <- CR_of_Q_zero. + apply CR_of_Q_lt; reflexivity. + rewrite CRmult_assoc, <- CR_of_Q_mult. + setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. + rewrite CR_of_Q_one, CRmult_1_r. + setoid_replace 2%Q with (1+1)%Q. rewrite CR_of_Q_plus, CR_of_Q_one. + rewrite CRmult_plus_distr_l, CRmult_1_r, CRplus_assoc. + apply CRplus_le_compat_l. + apply (CRplus_le_reg_l (-y)). + rewrite <- CRplus_assoc, CRplus_opp_l, CRplus_0_l. + rewrite CRabs_minus_sym, CRplus_comm. + apply CRle_abs. reflexivity. +Qed. + +Lemma CRmax_r : forall {R : ConstructiveReals} (x y : CRcarrier R), + y <= CRmax x y. +Proof. + intros. unfold CRmax. + apply (CRmult_le_reg_r (CR_of_Q _ 2)). rewrite <- CR_of_Q_zero. + apply CR_of_Q_lt; reflexivity. + rewrite CRmult_assoc, <- CR_of_Q_mult. + setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. + rewrite CR_of_Q_one, CRmult_1_r. + rewrite (CR_of_Q_plus _ 1 1), CRmult_plus_distr_l, CR_of_Q_one, CRmult_1_r. + rewrite (CRplus_comm x). + rewrite CRplus_assoc. apply CRplus_le_compat_l. + apply (CRplus_le_reg_l (-x)). + rewrite <- CRplus_assoc, CRplus_opp_l, CRplus_0_l. + rewrite CRplus_comm. apply CRle_abs. +Qed. + +Lemma CRposPartAbsMax : forall {R : ConstructiveReals} (x : CRcarrier R), + CRmax 0 x == (x + CRabs _ x) * (CR_of_Q R (1#2)). +Proof. + intros. unfold CRmax. unfold CRminus. rewrite CRplus_0_l. + apply CRmult_morph. 2: reflexivity. rewrite CRopp_0, CRplus_0_r. reflexivity. +Qed. + +Lemma CRmax_sym : forall {R : ConstructiveReals} (x y : CRcarrier R), + CRmax x y == CRmax y x. +Proof. + intros. unfold CRmax. + rewrite CRabs_minus_sym. apply CRmult_morph. + 2: reflexivity. rewrite (CRplus_comm x y). reflexivity. +Qed. + +Lemma CRmax_plus : forall {R : ConstructiveReals} (x y z : CRcarrier R), + x + CRmax y z == CRmax (x + y) (x + z). +Proof. + intros. unfold CRmax. + setoid_replace (x + z - (x + y)) with (z-y). + apply (CRmult_eq_reg_r (CR_of_Q _ 2)). + left. rewrite <- CR_of_Q_zero. apply CR_of_Q_lt; reflexivity. + rewrite CRmult_plus_distr_r. + rewrite CRmult_assoc, <- CR_of_Q_mult. + setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. + rewrite CR_of_Q_one, CRmult_1_r. + rewrite CRmult_assoc, <- CR_of_Q_mult. + setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. + rewrite (CR_of_Q_plus _ 1 1), CRmult_plus_distr_l, CR_of_Q_one, CRmult_1_r. + rewrite CRmult_1_r. + do 3 rewrite (CRplus_assoc x). apply CRplus_morph. reflexivity. + do 2 rewrite <- CRplus_assoc. apply CRplus_morph. 2: reflexivity. + rewrite (CRplus_comm x). apply CRplus_assoc. + unfold CRminus. rewrite CRopp_plus_distr. rewrite <- CRplus_assoc. + apply CRplus_morph. 2: reflexivity. + rewrite CRplus_comm, <- CRplus_assoc, CRplus_opp_l. + apply CRplus_0_l. +Qed. + +Lemma CRmax_left : forall {R : ConstructiveReals} (x y : CRcarrier R), + y <= x -> CRmax x y == x. +Proof. + intros. unfold CRmax. + apply (CRmult_eq_reg_r (CR_of_Q R 2)). + left. rewrite <- CR_of_Q_zero. apply CR_of_Q_lt; reflexivity. + rewrite CRmult_assoc, <- CR_of_Q_mult. + setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. + rewrite CR_of_Q_one, CRmult_1_r. + rewrite (CR_of_Q_plus _ 1 1), CRmult_plus_distr_l, CR_of_Q_one, CRmult_1_r. + rewrite CRplus_assoc. apply CRplus_morph. reflexivity. + rewrite CRabs_left. unfold CRminus. rewrite CRopp_plus_distr, CRopp_involutive. + rewrite <- CRplus_assoc, CRplus_opp_r, CRplus_0_l. reflexivity. + rewrite <- (CRplus_opp_r x). apply CRplus_le_compat_r. exact H. +Qed. + +Lemma CRmax_right : forall {R : ConstructiveReals} (x y : CRcarrier R), + x <= y -> CRmax x y == y. +Proof. + intros. unfold CRmax. + apply (CRmult_eq_reg_r (CR_of_Q R 2)). + left. rewrite <- CR_of_Q_zero. apply CR_of_Q_lt; reflexivity. + rewrite CRmult_assoc, <- CR_of_Q_mult. + setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. + rewrite CR_of_Q_one, CRmult_1_r. + rewrite (CR_of_Q_plus _ 1 1), CRmult_plus_distr_l, CR_of_Q_one, CRmult_1_r. + rewrite (CRplus_comm x y). + rewrite CRplus_assoc. apply CRplus_morph. reflexivity. + rewrite CRabs_right. unfold CRminus. rewrite CRplus_comm. + rewrite CRplus_assoc, CRplus_opp_l, CRplus_0_r. reflexivity. + rewrite <- (CRplus_opp_r x). apply CRplus_le_compat_r. exact H. +Qed. + +Lemma CRmax_contract : forall {R : ConstructiveReals} (x y a : CRcarrier R), + CRabs _ (CRmax x a - CRmax y a) <= CRabs _ (x - y). +Proof. + intros. unfold CRmax. + rewrite (CRabs_morph + _ ((x - y + (CRabs _ (a - x) - CRabs _ (a - y))) * CR_of_Q R (1 # 2))). + rewrite CRabs_mult, (CRabs_right (CR_of_Q R (1 # 2))). + 2: rewrite <- CR_of_Q_zero; apply CR_of_Q_le; discriminate. + apply (CRle_trans + _ ((CRabs _ (x - y) * 1 + CRabs _ (x-y) * 1) + * CR_of_Q R (1 # 2))). + apply CRmult_le_compat_r. + rewrite <- CR_of_Q_zero. apply CR_of_Q_le. discriminate. + apply (CRle_trans + _ (CRabs _ (x - y) + CRabs _ (CRabs _ (a - x) - CRabs _ (a - y)))). + apply CRabs_triang. rewrite CRmult_1_r. apply CRplus_le_compat_l. + rewrite (CRabs_minus_sym x y). + rewrite (CRabs_morph (y-x) ((a-x)-(a-y))). + apply CRabs_triang_inv2. + unfold CRminus. rewrite (CRplus_comm (a + - x)). + rewrite <- CRplus_assoc. apply CRplus_morph. 2: reflexivity. + rewrite CRplus_comm, CRopp_plus_distr, <- CRplus_assoc. + rewrite CRplus_opp_r, CRopp_involutive, CRplus_0_l. + reflexivity. + rewrite <- CRmult_plus_distr_l, <- CR_of_Q_one. + rewrite <- (CR_of_Q_plus R 1 1). + rewrite CRmult_assoc, <- CR_of_Q_mult. + setoid_replace ((1 + 1) * (1 # 2))%Q with 1%Q. 2: reflexivity. + rewrite CR_of_Q_one, CRmult_1_r. apply CRle_refl. + unfold CRminus. rewrite CRopp_mult_distr_l. + rewrite <- CRmult_plus_distr_r. apply CRmult_morph. 2: reflexivity. + do 4 rewrite CRplus_assoc. apply CRplus_morph. reflexivity. + rewrite <- CRplus_assoc. rewrite CRplus_comm, CRopp_plus_distr. + rewrite CRplus_assoc. apply CRplus_morph. reflexivity. + rewrite CRopp_plus_distr. rewrite (CRplus_comm (-a)). + rewrite CRplus_assoc, <- (CRplus_assoc (-a)), CRplus_opp_l. + rewrite CRplus_0_l. apply CRplus_comm. +Qed. + +Lemma CRmax_lub_lt : forall {R : ConstructiveReals} (x y z : CRcarrier R), + x < z -> y < z -> CRmax x y < z. +Proof. + intros. unfold CRmax. + apply (CRmult_lt_reg_r (CR_of_Q R 2)). + rewrite <- CR_of_Q_zero. apply CR_of_Q_lt; reflexivity. + rewrite CRmult_assoc, <- CR_of_Q_mult. + setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. + rewrite CR_of_Q_one, CRmult_1_r. + apply (CRplus_lt_reg_l _ (-y -x)). unfold CRminus. + rewrite CRplus_assoc, <- (CRplus_assoc (-x)), <- (CRplus_assoc (-x)). + rewrite CRplus_opp_l, CRplus_0_l, <- CRplus_assoc, CRplus_opp_l, CRplus_0_l. + apply CRabs_def1. + - rewrite (CRplus_comm y), (CRplus_comm (-y)), CRplus_assoc. + apply CRplus_lt_compat_l. + apply (CRplus_lt_reg_l _ y). + rewrite <- CRplus_assoc, CRplus_opp_r, CRplus_0_l. + rewrite (CR_of_Q_plus R 1 1), CR_of_Q_one, CRmult_plus_distr_l. + rewrite CRmult_1_r. apply CRplus_le_lt_compat. + apply CRlt_asym, H0. exact H0. + - rewrite CRopp_plus_distr, CRopp_involutive. + rewrite CRplus_assoc. apply CRplus_lt_compat_l. + apply (CRplus_lt_reg_l _ x). + rewrite <- CRplus_assoc, CRplus_opp_r, CRplus_0_l. + rewrite (CR_of_Q_plus R 1 1), CR_of_Q_one, CRmult_plus_distr_l. + rewrite CRmult_1_r. apply CRplus_le_lt_compat. + apply CRlt_asym, H. exact H. +Qed. + +Lemma CRmax_assoc : forall {R : ConstructiveReals} (a b c : CRcarrier R), + CRmax a (CRmax b c) == CRmax (CRmax a b) c. +Proof. + split. + - apply CRmax_lub. + + apply CRmax_lub. apply CRmax_l. + apply (CRle_trans _ (CRmax b c)). + apply CRmax_l. apply CRmax_r. + + apply (CRle_trans _ (CRmax b c)). + apply CRmax_r. apply CRmax_r. + - apply CRmax_lub. + + apply (CRle_trans _ (CRmax a b)). + apply CRmax_l. apply CRmax_l. + + apply CRmax_lub. + apply (CRle_trans _ (CRmax a b)). + apply CRmax_r. apply CRmax_l. apply CRmax_r. +Qed. + +Lemma CRmax_min_mult_neg : + forall {R : ConstructiveReals} (p q r:CRcarrier R), + r <= 0 -> CRmax (r * p) (r * q) == r * CRmin p q. +Proof. + intros R p q r H. unfold CRmin, CRmax. + setoid_replace (r * q - r * p) with (r * (q - p)). + rewrite CRabs_mult. + rewrite (CRabs_left r), <- CRmult_assoc. + apply CRmult_morph. 2: reflexivity. unfold CRminus. + rewrite <- CRopp_mult_distr_l, CRopp_mult_distr_r, + CRmult_plus_distr_l, CRmult_plus_distr_l. + reflexivity. exact H. + unfold CRminus. rewrite CRmult_plus_distr_l, CRopp_mult_distr_r. reflexivity. +Qed. + +Lemma CRlt_max : forall {R : ConstructiveReals} (x y z : CRcarrier R), + CRmax x y < z -> prod (x < z) (y < z). +Proof. + intros. destruct (CR_Q_dense R _ _ H) as [q qmaj]. + destruct qmaj. + split. + - apply (CRlt_le_trans _ (CR_of_Q R q)). + apply (CRle_lt_trans _ (CRmax x y)). apply CRmax_l. exact c. + apply CRlt_asym, c0. + - apply (CRlt_le_trans _ (CR_of_Q R q)). + apply (CRle_lt_trans _ (CRmax x y)). apply CRmax_r. exact c. + apply CRlt_asym, c0. +Qed. + +Lemma CRmax_mult : + forall {R : ConstructiveReals} (p q r:CRcarrier R), + 0 <= r -> CRmax (r * p) (r * q) == r * CRmax p q. +Proof. + intros R p q r H. unfold CRmin, CRmax. + setoid_replace (r * q - r * p) with (r * (q - p)). + rewrite CRabs_mult. + rewrite (CRabs_right r), <- CRmult_assoc. + apply CRmult_morph. 2: reflexivity. + rewrite CRmult_plus_distr_l, CRmult_plus_distr_l. + reflexivity. exact H. + unfold CRminus. rewrite CRmult_plus_distr_l, CRopp_mult_distr_r. reflexivity. +Qed. + +Lemma CRmin_max_mult_neg : + forall {R : ConstructiveReals} (p q r:CRcarrier R), + r <= 0 -> CRmin (r * p) (r * q) == r * CRmax p q. +Proof. + intros R p q r H. unfold CRmin, CRmax. + setoid_replace (r * q - r * p) with (r * (q - p)). + rewrite CRabs_mult. + rewrite (CRabs_left r), <- CRmult_assoc. + apply CRmult_morph. 2: reflexivity. unfold CRminus. + rewrite CRopp_mult_distr_l, CRopp_involutive, + CRmult_plus_distr_l, CRmult_plus_distr_l. + reflexivity. exact H. + unfold CRminus. rewrite CRmult_plus_distr_l, CRopp_mult_distr_r. reflexivity. +Qed. diff --git a/theories/Reals/Abstract/ConstructiveLUB.v b/theories/Reals/Abstract/ConstructiveLUB.v new file mode 100644 index 0000000000..4ae24de154 --- /dev/null +++ b/theories/Reals/Abstract/ConstructiveLUB.v @@ -0,0 +1,413 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) +(************************************************************************) + +(** Proof that LPO and the excluded middle for negations imply + the existence of least upper bounds for all non-empty and bounded + subsets of the real numbers. *) + +Require Import QArith_base Qabs. +Require Import ConstructiveReals. +Require Import ConstructiveAbs. +Require Import ConstructiveLimits. +Require Import Logic.ConstructiveEpsilon. + +Local Open Scope ConstructiveReals. + +Definition sig_forall_dec_T : Type + := forall (P : nat -> Prop), (forall n, {P n} + {~P n}) + -> {n | ~P n} + {forall n, P n}. + +Definition sig_not_dec_T : Type := forall P : Prop, { ~~P } + { ~P }. + +Definition is_upper_bound {R : ConstructiveReals} + (E:CRcarrier R -> Prop) (m:CRcarrier R) + := forall x:CRcarrier R, E x -> x <= m. + +Definition is_lub {R : ConstructiveReals} + (E:CRcarrier R -> Prop) (m:CRcarrier R) := + is_upper_bound E m /\ (forall b:CRcarrier R, is_upper_bound E b -> m <= b). + +Lemma CRlt_lpo_dec : forall {R : ConstructiveReals} (x y : CRcarrier R), + (forall (P : nat -> Prop), (forall n, {P n} + {~P n}) + -> {n | ~P n} + {forall n, P n}) + -> sum (x < y) (y <= x). +Proof. + intros R x y lpo. + assert (forall (z:CRcarrier R) (n : nat), z < z + CR_of_Q R (1 # Pos.of_nat (S n))). + { intros. apply (CRle_lt_trans _ (z+0)). + rewrite CRplus_0_r. apply CRle_refl. apply CRplus_lt_compat_l. + apply CR_of_Q_pos. reflexivity. } + pose (fun n:nat => let (q,_) := CR_Q_dense + R x (x + CR_of_Q R (1 # Pos.of_nat (S n))) (H x n) + in q) + as xn. + pose (fun n:nat => let (q,_) := CR_Q_dense + R y (y + CR_of_Q R (1 # Pos.of_nat (S n))) (H y n) + in q) + as yn. + destruct (lpo (fun n => Qle (yn n) (xn n + (1 # Pos.of_nat (S n))))). + - intro n. destruct (Q_dec (yn n) (xn n + (1 # Pos.of_nat (S n)))). + destruct s. left. apply Qlt_le_weak, q. + right. apply (Qlt_not_le _ _ q). left. + rewrite q. apply Qle_refl. + - left. destruct s as [n nmaj]. apply Qnot_le_lt in nmaj. + apply (CRlt_le_trans _ (CR_of_Q R (xn n))). + unfold xn. + destruct (CR_Q_dense R x (x + CR_of_Q R (1 # Pos.of_nat (S n))) (H x n)). + exact (fst p). apply (CRle_trans _ (CR_of_Q R (yn n - (1 # Pos.of_nat (S n))))). + apply CR_of_Q_le. rewrite <- (Qplus_le_l _ _ (1# Pos.of_nat (S n))). + ring_simplify. apply Qlt_le_weak, nmaj. + unfold yn. + destruct (CR_Q_dense R y (y + CR_of_Q R (1 # Pos.of_nat (S n))) (H y n)). + unfold Qminus. rewrite CR_of_Q_plus, CR_of_Q_opp. + apply (CRplus_le_reg_r (CR_of_Q R (1 # Pos.of_nat (S n)))). + rewrite CRplus_assoc, CRplus_opp_l, CRplus_0_r. + apply CRlt_asym, (snd p). + - right. apply (CR_cv_le (fun n => CR_of_Q R (yn n)) + (fun n => CR_of_Q R (xn n) + CR_of_Q R (1 # Pos.of_nat (S n)))). + + intro n. rewrite <- CR_of_Q_plus. apply CR_of_Q_le. exact (q n). + + intro p. exists (Pos.to_nat p). intros. + unfold yn. + destruct (CR_Q_dense R y (y + CR_of_Q R (1 # Pos.of_nat (S i))) (H y i)). + rewrite CRabs_right. apply (CRplus_le_reg_r y). + unfold CRminus. rewrite CRplus_assoc, CRplus_opp_l, CRplus_0_r. + rewrite CRplus_comm. + apply (CRle_trans _ (y + CR_of_Q R (1 # Pos.of_nat (S i)))). + apply CRlt_asym, (snd p0). apply CRplus_le_compat_l. + apply CR_of_Q_le. unfold Qle, Qnum, Qden. + rewrite Z.mul_1_l, Z.mul_1_l. apply Pos2Z.pos_le_pos. + apply Pos2Nat.inj_le. rewrite Nat2Pos.id. + apply le_S, H0. discriminate. rewrite <- (CRplus_opp_r y). + apply CRplus_le_compat_r, CRlt_asym, p0. + + apply (CR_cv_proper _ (x+0)). 2: rewrite CRplus_0_r; reflexivity. + apply CR_cv_plus. + intro p. exists (Pos.to_nat p). intros. + unfold xn. + destruct (CR_Q_dense R x (x + CR_of_Q R (1 # Pos.of_nat (S i))) (H x i)). + rewrite CRabs_right. apply (CRplus_le_reg_r x). + unfold CRminus. rewrite CRplus_assoc, CRplus_opp_l, CRplus_0_r. + rewrite CRplus_comm. + apply (CRle_trans _ (x + CR_of_Q R (1 # Pos.of_nat (S i)))). + apply CRlt_asym, (snd p0). apply CRplus_le_compat_l. + apply CR_of_Q_le. unfold Qle, Qnum, Qden. + rewrite Z.mul_1_l, Z.mul_1_l. apply Pos2Z.pos_le_pos. + apply Pos2Nat.inj_le. rewrite Nat2Pos.id. + apply le_S, H0. discriminate. rewrite <- (CRplus_opp_r x). + apply CRplus_le_compat_r, CRlt_asym, p0. + intro p. exists (Pos.to_nat p). intros. + unfold CRminus. rewrite CRopp_0, CRplus_0_r, CRabs_right. + apply CR_of_Q_le. unfold Qle, Qnum, Qden. + rewrite Z.mul_1_l, Z.mul_1_l. apply Pos2Z.pos_le_pos. + apply Pos2Nat.inj_le. rewrite Nat2Pos.id. + apply le_S, H0. discriminate. + rewrite <- CR_of_Q_zero. apply CR_of_Q_le. discriminate. +Qed. + +Lemma is_upper_bound_dec : + forall {R : ConstructiveReals} (E:CRcarrier R -> Prop) (x:CRcarrier R), + sig_forall_dec_T + -> sig_not_dec_T + -> { is_upper_bound E x } + { ~is_upper_bound E x }. +Proof. + intros R E x lpo sig_not_dec. + destruct (sig_not_dec (~exists y:CRcarrier R, E y /\ CRltProp R x y)). + - left. intros y H. + destruct (CRlt_lpo_dec x y lpo). 2: exact c. + exfalso. apply n. intro abs. apply abs. clear abs. + exists y. split. exact H. apply CRltForget. exact c. + - right. intro abs. apply n. intros [y [H H0]]. + specialize (abs y H). apply CRltEpsilon in H0. contradiction. +Qed. + +Lemma is_upper_bound_epsilon : + forall {R : ConstructiveReals} (E:CRcarrier R -> Prop), + sig_forall_dec_T + -> sig_not_dec_T + -> (exists x:CRcarrier R, is_upper_bound E x) + -> { n:nat | is_upper_bound E (CR_of_Q R (Z.of_nat n # 1)) }. +Proof. + intros R E lpo sig_not_dec Ebound. + apply constructive_indefinite_ground_description_nat. + - intro n. apply is_upper_bound_dec. exact lpo. exact sig_not_dec. + - destruct Ebound as [x H]. destruct (CRup_nat x) as [n nmaj]. exists n. + intros y ey. specialize (H y ey). + apply (CRle_trans _ x _ H). apply CRlt_asym, nmaj. +Qed. + +Lemma is_upper_bound_not_epsilon : + forall {R : ConstructiveReals} (E:CRcarrier R -> Prop), + sig_forall_dec_T + -> sig_not_dec_T + -> (exists x : CRcarrier R, E x) + -> { m:nat | ~is_upper_bound E (-CR_of_Q R (Z.of_nat m # 1)) }. +Proof. + intros R E lpo sig_not_dec H. + apply constructive_indefinite_ground_description_nat. + - intro n. + destruct (is_upper_bound_dec E (-CR_of_Q R (Z.of_nat n # 1)) lpo sig_not_dec). + right. intro abs. contradiction. left. exact n0. + - destruct H as [x H]. destruct (CRup_nat (-x)) as [n H0]. + exists n. intro abs. specialize (abs x H). + apply abs. rewrite <- (CRopp_involutive x). + apply CRopp_gt_lt_contravar. exact H0. +Qed. + +(* Decidable Dedekind cuts are Cauchy reals. *) +Record DedekindDecCut : Type := + { + DDupcut : Q -> Prop; + DDproper : forall q r : Q, (q == r -> DDupcut q -> DDupcut r)%Q; + DDlow : Q; + DDhigh : Q; + DDdec : forall q:Q, { DDupcut q } + { ~DDupcut q }; + DDinterval : forall q r : Q, Qle q r -> DDupcut q -> DDupcut r; + DDhighProp : DDupcut DDhigh; + DDlowProp : ~DDupcut DDlow; + }. + +Lemma DDlow_below_up : forall (upcut : DedekindDecCut) (a b : Q), + DDupcut upcut a -> ~DDupcut upcut b -> Qlt b a. +Proof. + intros. destruct (Qlt_le_dec b a). exact q. + exfalso. apply H0. apply (DDinterval upcut a). + exact q. exact H. +Qed. + +Fixpoint DDcut_limit_fix (upcut : DedekindDecCut) (r : Q) (n : nat) : + Qlt 0 r + -> (DDupcut upcut (DDlow upcut + (Z.of_nat n#1) * r)) + -> { q : Q | DDupcut upcut q /\ ~DDupcut upcut (q - r) }. +Proof. + destruct n. + - intros. exfalso. simpl in H0. + apply (DDproper upcut _ (DDlow upcut)) in H0. 2: ring. + exact (DDlowProp upcut H0). + - intros. destruct (DDdec upcut (DDlow upcut + (Z.of_nat n # 1) * r)). + + exact (DDcut_limit_fix upcut r n H d). + + exists (DDlow upcut + (Z.of_nat (S n) # 1) * r)%Q. split. + exact H0. intro abs. + apply (DDproper upcut _ (DDlow upcut + (Z.of_nat n # 1) * r)) in abs. + contradiction. + rewrite Nat2Z.inj_succ. unfold Z.succ. rewrite <- Qinv_plus_distr. + ring. +Qed. + +Lemma DDcut_limit : forall (upcut : DedekindDecCut) (r : Q), + Qlt 0 r + -> { q : Q | DDupcut upcut q /\ ~DDupcut upcut (q - r) }. +Proof. + intros. + destruct (Qarchimedean ((DDhigh upcut - DDlow upcut)/r)) as [n nmaj]. + apply (DDcut_limit_fix upcut r (Pos.to_nat n) H). + apply (Qmult_lt_r _ _ r) in nmaj. 2: exact H. + unfold Qdiv in nmaj. + rewrite <- Qmult_assoc, (Qmult_comm (/r)), Qmult_inv_r, Qmult_1_r in nmaj. + apply (DDinterval upcut (DDhigh upcut)). 2: exact (DDhighProp upcut). + apply Qlt_le_weak. apply (Qplus_lt_r _ _ (-DDlow upcut)). + rewrite Qplus_assoc, <- (Qplus_comm (DDlow upcut)), Qplus_opp_r, + Qplus_0_l, Qplus_comm. + rewrite positive_nat_Z. exact nmaj. + intros abs. rewrite abs in H. exact (Qlt_irrefl 0 H). +Qed. + +Lemma glb_dec_Q : forall {R : ConstructiveReals} (upcut : DedekindDecCut), + { x : CRcarrier R + | forall r:Q, (x < CR_of_Q R r -> DDupcut upcut r) + /\ (CR_of_Q R r < x -> ~DDupcut upcut r) }. +Proof. + intros. + assert (forall a b : Q, Qle a b -> Qle (-b) (-a)). + { intros. apply (Qplus_le_l _ _ (a+b)). ring_simplify. exact H. } + assert (CR_cauchy R (fun n:nat => CR_of_Q R (proj1_sig (DDcut_limit + upcut (1#Pos.of_nat n) (eq_refl _))))). + { intros p. exists (Pos.to_nat p). intros i j pi pj. + destruct (DDcut_limit upcut (1 # Pos.of_nat i) eq_refl), + (DDcut_limit upcut (1 # Pos.of_nat j) eq_refl); unfold proj1_sig. + apply (CRabs_le). split. + - intros. unfold CRminus. + rewrite <- CR_of_Q_opp, <- CR_of_Q_opp, <- CR_of_Q_plus. + apply CR_of_Q_le. + apply (Qplus_le_l _ _ x0). ring_simplify. + setoid_replace (-1 * (1 # p) + x0)%Q with (x0 - (1 # p))%Q. + 2: ring. apply (Qle_trans _ (x0- (1#Pos.of_nat j))). + apply Qplus_le_r. apply H. + apply Z2Nat.inj_le. discriminate. discriminate. simpl. + rewrite Nat2Pos.id. exact pj. intro abs. + subst j. inversion pj. pose proof (Pos2Nat.is_pos p). + rewrite H1 in H0. inversion H0. + apply Qlt_le_weak, (DDlow_below_up upcut). apply a. apply a0. + - unfold CRminus. rewrite <- CR_of_Q_opp, <- CR_of_Q_plus. + apply CR_of_Q_le. + apply (Qplus_le_l _ _ (x0-(1#p))). ring_simplify. + setoid_replace (x -1 * (1 # p))%Q with (x - (1 # p))%Q. + 2: ring. apply (Qle_trans _ (x- (1#Pos.of_nat i))). + apply Qplus_le_r. apply H. + apply Z2Nat.inj_le. discriminate. discriminate. simpl. + rewrite Nat2Pos.id. exact pi. intro abs. + subst i. inversion pi. pose proof (Pos2Nat.is_pos p). + rewrite H1 in H0. inversion H0. + apply Qlt_le_weak, (DDlow_below_up upcut). apply a0. apply a. } + apply CR_complete in H0. destruct H0 as [l lcv]. + exists l. split. + - intros. (* find an upper point between the limit and r *) + destruct (CR_cv_open_above _ (CR_of_Q R r) l lcv H0) as [p pmaj]. + specialize (pmaj p (le_refl p)). + unfold proj1_sig in pmaj. + destruct (DDcut_limit upcut (1 # Pos.of_nat p) eq_refl) as [q qmaj]. + apply (DDinterval upcut q). 2: apply qmaj. + destruct (Q_dec q r). destruct s. apply Qlt_le_weak, q0. + exfalso. apply (CR_of_Q_lt R) in q0. exact (CRlt_asym _ _ pmaj q0). + rewrite q0. apply Qle_refl. + - intros H0 abs. + assert ((CR_of_Q R r+l) * CR_of_Q R (1#2) < l). + { apply (CRmult_lt_reg_r (CR_of_Q R 2)). + apply CR_of_Q_pos. reflexivity. + rewrite CRmult_assoc, <- CR_of_Q_mult, (CR_of_Q_plus R 1 1). + setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. + rewrite CR_of_Q_one, CRmult_plus_distr_l, CRmult_1_r, CRmult_1_r. + apply CRplus_lt_compat_r. exact H0. } + destruct (CR_cv_open_below _ _ l lcv H1) as [p pmaj]. + assert (0 < (l-CR_of_Q R r) * CR_of_Q R (1#2)). + { apply CRmult_lt_0_compat. rewrite <- (CRplus_opp_r (CR_of_Q R r)). + apply CRplus_lt_compat_r. exact H0. apply CR_of_Q_pos. reflexivity. } + destruct (CRup_nat (CRinv R _ (inr H2))) as [i imaj]. + destruct i. exfalso. simpl in imaj. + rewrite CR_of_Q_zero in imaj. + exact (CRlt_asym _ _ imaj (CRinv_0_lt_compat R _ (inr H2) H2)). + specialize (pmaj (max (S i) (S p)) (le_trans p (S p) _ (le_S p p (le_refl p)) (Nat.le_max_r (S i) (S p)))). + unfold proj1_sig in pmaj. + destruct (DDcut_limit upcut (1 # Pos.of_nat (max (S i) (S p))) eq_refl) + as [q qmaj]. + destruct qmaj. apply H4. clear H4. + apply (DDinterval upcut r). 2: exact abs. + apply (Qplus_le_l _ _ (1 # Pos.of_nat (Init.Nat.max (S i) (S p)))). + ring_simplify. apply (Qle_trans _ (r + (1 # Pos.of_nat (S i)))). + rewrite Qplus_le_r. unfold Qle,Qnum,Qden. + rewrite Z.mul_1_l, Z.mul_1_l. apply Pos2Z.pos_le_pos. + apply Pos2Nat.inj_le. rewrite Nat2Pos.id, Nat2Pos.id. + apply Nat.le_max_l. discriminate. discriminate. + apply (CRmult_lt_compat_l ((l - CR_of_Q R r) * CR_of_Q R (1 # 2))) in imaj. + rewrite CRinv_r in imaj. 2: exact H2. + destruct (Q_dec (r+(1#Pos.of_nat (S i))) q). destruct s. + apply Qlt_le_weak, q0. 2: rewrite q0; apply Qle_refl. + exfalso. apply (CR_of_Q_lt R) in q0. + apply (CRlt_asym _ _ pmaj). apply (CRlt_le_trans _ _ _ q0). + apply (CRplus_le_reg_l (-CR_of_Q R r)). + rewrite CR_of_Q_plus, <- CRplus_assoc, CRplus_opp_l, CRplus_0_l. + apply (CRmult_lt_compat_r (CR_of_Q R (1 # Pos.of_nat (S i)))) in imaj. + rewrite CRmult_1_l in imaj. + apply (CRle_trans _ ( + (l - CR_of_Q R r) * CR_of_Q R (1 # 2) * CR_of_Q R (Z.of_nat (S i) # 1) * + CR_of_Q R (1 # Pos.of_nat (S i)))). + apply CRlt_asym, imaj. rewrite CRmult_assoc, <- CR_of_Q_mult. + setoid_replace ((Z.of_nat (S i) # 1) * (1 # Pos.of_nat (S i)))%Q with 1%Q. + rewrite CR_of_Q_one, CRmult_1_r. + unfold CRminus. rewrite CRmult_plus_distr_r, (CRplus_comm (-CR_of_Q R r)). + rewrite (CRplus_comm (CR_of_Q R r)), CRmult_plus_distr_r. + rewrite CRplus_assoc. apply CRplus_le_compat_l. + rewrite <- CR_of_Q_mult, <- CR_of_Q_opp, <- CR_of_Q_mult, <- CR_of_Q_plus. + apply CR_of_Q_le. ring_simplify. apply Qle_refl. + unfold Qeq, Qmult, Qnum, Qden. rewrite Z.mul_1_r, Z.mul_1_r. + rewrite Z.mul_1_l, Pos.mul_1_l. unfold Z.of_nat. + apply f_equal. apply Pos.of_nat_succ. apply CR_of_Q_pos. reflexivity. +Qed. + +Lemma is_upper_bound_glb : + forall {R : ConstructiveReals} (E:CRcarrier R -> Prop), + sig_not_dec_T + -> sig_forall_dec_T + -> (exists x : CRcarrier R, E x) + -> (exists x : CRcarrier R, is_upper_bound E x) + -> { x : CRcarrier R + | forall r:Q, (x < CR_of_Q R r -> is_upper_bound E (CR_of_Q R r)) + /\ (CR_of_Q R r < x -> ~is_upper_bound E (CR_of_Q R r)) }. +Proof. + intros R E sig_not_dec lpo Einhab Ebound. + destruct (is_upper_bound_epsilon E lpo sig_not_dec Ebound) as [a luba]. + destruct (is_upper_bound_not_epsilon E lpo sig_not_dec Einhab) as [b glbb]. + pose (fun q => is_upper_bound E (CR_of_Q R q)) as upcut. + assert (forall q:Q, { upcut q } + { ~upcut q } ). + { intro q. apply is_upper_bound_dec. exact lpo. exact sig_not_dec. } + assert (forall q r : Q, (q <= r)%Q -> upcut q -> upcut r). + { intros. intros x Ex. specialize (H1 x Ex). intro abs. + apply H1. apply (CRle_lt_trans _ (CR_of_Q R r)). 2: exact abs. + apply CR_of_Q_le. exact H0. } + assert (upcut (Z.of_nat a # 1)%Q). + { intros x Ex. exact (luba x Ex). } + assert (~upcut (- Z.of_nat b # 1)%Q). + { intros abs. apply glbb. intros x Ex. + specialize (abs x Ex). rewrite <- CR_of_Q_opp. + exact abs. } + assert (forall q r : Q, (q == r)%Q -> upcut q -> upcut r). + { intros. intros x Ex. specialize (H4 x Ex). rewrite <- H3. exact H4. } + destruct (@glb_dec_Q R (Build_DedekindDecCut + upcut H3 (-Z.of_nat b # 1)%Q (Z.of_nat a # 1) + H H0 H1 H2)). + simpl in a0. exists x. intro r. split. + - intros. apply a0. exact H4. + - intros H6 abs. specialize (a0 r) as [_ a0]. apply a0. + exact H6. exact abs. +Qed. + +Lemma is_upper_bound_closed : + forall {R : ConstructiveReals} + (E:CRcarrier R -> Prop) (sig_forall_dec : sig_forall_dec_T) + (sig_not_dec : sig_not_dec_T) + (Einhab : exists x : CRcarrier R, E x) + (Ebound : exists x : CRcarrier R, is_upper_bound E x), + is_lub + E (proj1_sig (is_upper_bound_glb + E sig_not_dec sig_forall_dec Einhab Ebound)). +Proof. + intros. split. + - intros x Ex. + destruct (is_upper_bound_glb E sig_not_dec sig_forall_dec Einhab Ebound); simpl. + intro abs. destruct (CR_Q_dense R x0 x abs) as [q [qmaj H]]. + specialize (a q) as [a _]. specialize (a qmaj x Ex). + contradiction. + - intros. + destruct (is_upper_bound_glb E sig_not_dec sig_forall_dec Einhab Ebound); simpl. + intro abs. destruct (CR_Q_dense R b x abs) as [q [qmaj H0]]. + specialize (a q) as [_ a]. apply a. exact H0. + intros y Ey. specialize (H y Ey). intro abs2. + apply H. exact (CRlt_trans _ (CR_of_Q R q) _ qmaj abs2). +Qed. + +Lemma sig_lub : + forall {R : ConstructiveReals} (E:CRcarrier R -> Prop), + sig_forall_dec_T + -> sig_not_dec_T + -> (exists x : CRcarrier R, E x) + -> (exists x : CRcarrier R, is_upper_bound E x) + -> { u : CRcarrier R | is_lub E u }. +Proof. + intros R E sig_forall_dec sig_not_dec Einhab Ebound. + pose proof (is_upper_bound_closed E sig_forall_dec sig_not_dec Einhab Ebound). + destruct (is_upper_bound_glb + E sig_not_dec sig_forall_dec Einhab Ebound); simpl in H. + exists x. exact H. +Qed. + +Definition CRis_upper_bound {R : ConstructiveReals} (E:CRcarrier R -> Prop) (m:CRcarrier R) + := forall x:CRcarrier R, E x -> CRlt R m x -> False. + +Lemma CR_sig_lub : + forall {R : ConstructiveReals} (E:CRcarrier R -> Prop), + (forall x y : CRcarrier R, CReq R x y -> (E x <-> E y)) + -> sig_forall_dec_T + -> sig_not_dec_T + -> (exists x : CRcarrier R, E x) + -> (exists x : CRcarrier R, CRis_upper_bound E x) + -> { u : CRcarrier R | CRis_upper_bound E u /\ + forall y:CRcarrier R, CRis_upper_bound E y -> CRlt R y u -> False }. +Proof. + intros. exact (sig_lub E X X0 H0 H1). +Qed. diff --git a/theories/Reals/Abstract/ConstructiveLimits.v b/theories/Reals/Abstract/ConstructiveLimits.v new file mode 100644 index 0000000000..4a40cc8cb3 --- /dev/null +++ b/theories/Reals/Abstract/ConstructiveLimits.v @@ -0,0 +1,933 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +Require Import QArith Qabs. +Require Import ConstructiveReals. +Require Import ConstructiveAbs. +Require Import ConstructiveSum. + +Local Open Scope ConstructiveReals. + + +(** Definitions and basic properties of limits of real sequences + and series. *) + + +Lemma CR_cv_extens + : forall {R : ConstructiveReals} (xn yn : nat -> CRcarrier R) (l : CRcarrier R), + (forall n:nat, xn n == yn n) + -> CR_cv R xn l + -> CR_cv R yn l. +Proof. + intros. intro p. specialize (H0 p) as [n nmaj]. exists n. + intros. specialize (nmaj i H0). + apply (CRle_trans _ (CRabs R (CRminus R (xn i) l))). + 2: exact nmaj. rewrite <- CRabs_def. split. + - apply (CRle_trans _ (CRminus R (xn i) l)). + apply CRplus_le_compat_r. specialize (H i) as [H _]. exact H. + pose proof (CRabs_def R (CRminus R (xn i) l) (CRabs R (CRminus R (xn i) l))) + as [_ H1]. + apply H1. apply CRle_refl. + - apply (CRle_trans _ (CRopp R (CRminus R (xn i) l))). + intro abs. apply CRopp_lt_cancel, CRplus_lt_reg_r in abs. + specialize (H i) as [_ H]. contradiction. + pose proof (CRabs_def R (CRminus R (xn i) l) (CRabs R (CRminus R (xn i) l))) + as [_ H1]. + apply H1. apply CRle_refl. +Qed. + +Lemma CR_cv_opp : forall {R : ConstructiveReals} (xn : nat -> CRcarrier R) (l : CRcarrier R), + CR_cv R xn l + -> CR_cv R (fun n => - xn n) (- l). +Proof. + intros. intro p. specialize (H p) as [n nmaj]. + exists n. intros. specialize (nmaj i H). + apply (CRle_trans _ (CRabs R (CRminus R (xn i) l))). + 2: exact nmaj. clear nmaj H. + unfold CRminus. rewrite <- CRopp_plus_distr, CRabs_opp. + apply CRle_refl. +Qed. + +Lemma CR_cv_plus : forall {R : ConstructiveReals} (xn yn : nat -> CRcarrier R) (a b : CRcarrier R), + CR_cv R xn a + -> CR_cv R yn b + -> CR_cv R (fun n => xn n + yn n) (a + b). +Proof. + intros. intro p. + specialize (H (2*p)%positive) as [i imaj]. + specialize (H0 (2*p)%positive) as [j jmaj]. + exists (max i j). intros. + apply (CRle_trans + _ (CRabs R (CRplus R (CRminus R (xn i0) a) (CRminus R (yn i0) b)))). + apply CRabs_morph. + - unfold CRminus. + do 2 rewrite <- (Radd_assoc (CRisRing R)). + apply CRplus_morph. reflexivity. rewrite CRopp_plus_distr. + destruct (CRisRing R). rewrite Radd_comm, <- Radd_assoc. + apply CRplus_morph. reflexivity. + rewrite Radd_comm. reflexivity. + - apply (CRle_trans _ _ _ (CRabs_triang _ _)). + apply (CRle_trans _ (CRplus R (CR_of_Q R (1 # 2*p)) (CR_of_Q R (1 # 2*p)))). + apply CRplus_le_compat. apply imaj, (le_trans _ _ _ (Nat.le_max_l _ _) H). + apply jmaj, (le_trans _ _ _ (Nat.le_max_r _ _) H). + apply (CRle_trans _ (CR_of_Q R ((1 # 2 * p) + (1 # 2 * p)))). + apply CR_of_Q_plus. apply CR_of_Q_le. + rewrite Qinv_plus_distr. setoid_replace (1 + 1 # 2 * p) with (1 # p). + apply Qle_refl. reflexivity. +Qed. + +Lemma CR_cv_unique : forall {R : ConstructiveReals} (xn : nat -> CRcarrier R) + (a b : CRcarrier R), + CR_cv R xn a + -> CR_cv R xn b + -> a == b. +Proof. + intros. assert (CR_cv R (fun _ => CRzero R) (CRminus R b a)). + { apply (CR_cv_extens (fun n => CRminus R (xn n) (xn n))). + intro n. unfold CRminus. apply CRplus_opp_r. + apply CR_cv_plus. exact H0. apply CR_cv_opp, H. } + assert (forall q r : Q, 0 < q -> / q < r -> 1 < q * r)%Q. + { intros. apply (Qmult_lt_l _ _ q) in H3. + rewrite Qmult_inv_r in H3. exact H3. intro abs. + rewrite abs in H2. exact (Qlt_irrefl 0 H2). exact H2. } + clear H H0 xn. remember (CRminus R b a) as z. + assert (z == 0). split. + - intro abs. destruct (CR_Q_dense R _ _ abs) as [q [H0 H]]. + destruct (Qarchimedean (/(-q))) as [p pmaj]. + specialize (H1 p) as [n nmaj]. + specialize (nmaj n (le_refl n)). apply nmaj. + apply (CRlt_trans _ (CR_of_Q R (-q))). apply CR_of_Q_lt. + apply H2 in pmaj. + apply (Qmult_lt_r _ _ (1#p)) in pmaj. 2: reflexivity. + rewrite Qmult_1_l, <- Qmult_assoc in pmaj. + setoid_replace ((Z.pos p # 1) * (1 # p))%Q with 1%Q in pmaj. + rewrite Qmult_1_r in pmaj. exact pmaj. unfold Qeq, Qnum, Qden; simpl. + do 2 rewrite Pos.mul_1_r. reflexivity. + apply (Qplus_lt_l _ _ q). ring_simplify. + apply (lt_CR_of_Q R q 0). apply (CRlt_le_trans _ (CRzero R) _ H). + apply CR_of_Q_zero. + apply (CRlt_le_trans _ (CRopp R z)). + apply (CRle_lt_trans _ (CRopp R (CR_of_Q R q))). apply CR_of_Q_opp. + apply CRopp_gt_lt_contravar, H0. + apply (CRle_trans _ (CRabs R (CRopp R z))). + pose proof (CRabs_def R (CRopp R z) (CRabs R (CRopp R z))) as [_ H1]. + apply H1, CRle_refl. + apply CRabs_morph. unfold CRminus. symmetry. apply CRplus_0_l. + - intro abs. destruct (CR_Q_dense R _ _ abs) as [q [H0 H]]. + destruct (Qarchimedean (/q)) as [p pmaj]. + specialize (H1 p) as [n nmaj]. + specialize (nmaj n (le_refl n)). apply nmaj. + apply (CRlt_trans _ (CR_of_Q R q)). apply CR_of_Q_lt. + apply H2 in pmaj. + apply (Qmult_lt_r _ _ (1#p)) in pmaj. 2: reflexivity. + rewrite Qmult_1_l, <- Qmult_assoc in pmaj. + setoid_replace ((Z.pos p # 1) * (1 # p))%Q with 1%Q in pmaj. + rewrite Qmult_1_r in pmaj. exact pmaj. unfold Qeq, Qnum, Qden; simpl. + do 2 rewrite Pos.mul_1_r. reflexivity. + apply (lt_CR_of_Q R 0 q). apply (CRle_lt_trans _ (CRzero R)). + 2: exact H0. apply CR_of_Q_zero. + apply (CRlt_le_trans _ _ _ H). + apply (CRle_trans _ (CRabs R (CRopp R z))). + apply (CRle_trans _ (CRabs R z)). + pose proof (CRabs_def R z (CRabs R z)) as [_ H1]. + apply H1. apply CRle_refl. apply CRabs_opp. + apply CRabs_morph. unfold CRminus. symmetry. apply CRplus_0_l. + - subst z. apply (CRplus_eq_reg_l (CRopp R a)). + apply (CReq_trans _ (CRzero R)). apply CRplus_opp_l. + destruct (CRisRing R). + apply (CReq_trans _ (CRplus R b (CRopp R a))). apply CReq_sym, H. + apply Radd_comm. +Qed. + +Lemma CR_cv_eq : forall {R : ConstructiveReals} + (v u : nat -> CRcarrier R) (s : CRcarrier R), + (forall n:nat, u n == v n) + -> CR_cv R u s + -> CR_cv R v s. +Proof. + intros R v u s seq H1 p. specialize (H1 p) as [N H0]. + exists N. intros. unfold CRminus. rewrite <- seq. apply H0, H. +Qed. + +Lemma CR_cauchy_eq : forall {R : ConstructiveReals} + (un vn : nat -> CRcarrier R), + (forall n:nat, un n == vn n) + -> CR_cauchy R un + -> CR_cauchy R vn. +Proof. + intros. intro p. specialize (H0 p) as [n H0]. + exists n. intros. specialize (H0 i j H1 H2). + unfold CRminus in H0. rewrite <- CRabs_def. + rewrite <- CRabs_def in H0. + do 2 rewrite H in H0. exact H0. +Qed. + +Lemma CR_cv_proper : forall {R : ConstructiveReals} + (un : nat -> CRcarrier R) (a b : CRcarrier R), + CR_cv R un a + -> a == b + -> CR_cv R un b. +Proof. + intros. intro p. specialize (H p) as [n H]. + exists n. intros. unfold CRminus. rewrite <- H0. apply H, H1. +Qed. + +Instance CR_cv_morph + : forall {R : ConstructiveReals} (un : nat -> CRcarrier R), CMorphisms.Proper + (CMorphisms.respectful (CReq R) CRelationClasses.iffT) (CR_cv R un). +Proof. + split. intros. apply (CR_cv_proper un x). exact H0. exact H. + intros. apply (CR_cv_proper un y). exact H0. symmetry. exact H. +Qed. + +Lemma Un_cv_nat_real : forall {R : ConstructiveReals} + (un : nat -> CRcarrier R) (l : CRcarrier R), + CR_cv R un l + -> forall eps : CRcarrier R, + 0 < eps + -> { p : nat & forall i:nat, le p i -> CRabs R (un i - l) < eps }. +Proof. + intros. destruct (CR_archimedean R (CRinv R eps (inr H0))) as [k kmaj]. + assert (0 < CR_of_Q R (Z.pos k # 1)). + { rewrite <- CR_of_Q_zero. apply CR_of_Q_lt. reflexivity. } + specialize (H k) as [p pmaj]. + exists p. intros. + apply (CRle_lt_trans _ (CR_of_Q R (1 # k))). + apply pmaj, H. + apply (CRmult_lt_reg_l (CR_of_Q R (Z.pos k # 1))). exact H1. + rewrite <- CR_of_Q_mult. + apply (CRle_lt_trans _ 1). + rewrite <- CR_of_Q_one. apply CR_of_Q_le. + unfold Qle; simpl. do 2 rewrite Pos.mul_1_r. apply Z.le_refl. + apply (CRmult_lt_reg_r (CRinv R eps (inr H0))). + apply CRinv_0_lt_compat, H0. rewrite CRmult_1_l, CRmult_assoc. + rewrite CRinv_r, CRmult_1_r. exact kmaj. +Qed. + +Lemma Un_cv_real_nat : forall {R : ConstructiveReals} + (un : nat -> CRcarrier R) (l : CRcarrier R), + (forall eps : CRcarrier R, + 0 < eps + -> { p : nat & forall i:nat, le p i -> CRabs R (un i - l) < eps }) + -> CR_cv R un l. +Proof. + intros. intros n. + specialize (H (CR_of_Q R (1#n))) as [p pmaj]. + rewrite <- CR_of_Q_zero. apply CR_of_Q_lt. reflexivity. + exists p. intros. apply CRlt_asym. apply pmaj. apply H. +Qed. + +Definition series_cv {R : ConstructiveReals} + (un : nat -> CRcarrier R) (s : CRcarrier R) : Set + := CR_cv R (CRsum un) s. + +Definition series_cv_lim_lt {R : ConstructiveReals} + (un : nat -> CRcarrier R) (x : CRcarrier R) : Set + := { l : CRcarrier R & prod (series_cv un l) (l < x) }. + +Definition series_cv_le_lim {R : ConstructiveReals} + (x : CRcarrier R) (un : nat -> CRcarrier R) : Set + := { l : CRcarrier R & prod (series_cv un l) (x <= l) }. + +Lemma CR_cv_minus : + forall {R : ConstructiveReals} + (An Bn:nat -> CRcarrier R) (l1 l2:CRcarrier R), + CR_cv R An l1 -> CR_cv R Bn l2 + -> CR_cv R (fun i:nat => An i - Bn i) (l1 - l2). +Proof. + intros. apply CR_cv_plus. apply H. + intros p. specialize (H0 p) as [n H0]. exists n. + intros. setoid_replace (- Bn i - - l2) with (- (Bn i - l2)). + rewrite CRabs_opp. apply H0, H1. unfold CRminus. + rewrite CRopp_plus_distr, CRopp_involutive. reflexivity. +Qed. + +Lemma CR_cv_nonneg : + forall {R : ConstructiveReals} (An:nat -> CRcarrier R) (l:CRcarrier R), + CR_cv R An l + -> (forall n:nat, 0 <= An n) + -> 0 <= l. +Proof. + intros. intro abs. + destruct (Un_cv_nat_real _ l H (-l)) as [N H1]. + rewrite <- CRopp_0. apply CRopp_gt_lt_contravar. apply abs. + specialize (H1 N (le_refl N)). + pose proof (CRabs_def R (An N - l) (CRabs R (An N - l))) as [_ H2]. + apply (CRle_lt_trans _ _ _ (CRle_abs _)) in H1. + apply (H0 N). apply (CRplus_lt_reg_r (-l)). + rewrite CRplus_0_l. exact H1. +Qed. + +Lemma series_cv_unique : + forall {R : ConstructiveReals} (Un:nat -> CRcarrier R) (l1 l2:CRcarrier R), + series_cv Un l1 -> series_cv Un l2 -> l1 == l2. +Proof. + intros. apply (CR_cv_unique (CRsum Un)); assumption. +Qed. + +Lemma CR_cv_scale : forall {R : ConstructiveReals} (u : nat -> CRcarrier R) + (a : CRcarrier R) (s : CRcarrier R), + CR_cv R u s -> CR_cv R (fun n => u n * a) (s * a). +Proof. + intros. intros n. + destruct (CR_archimedean R (1 + CRabs R a)). + destruct (H (n * x)%positive). + exists x0. intros. + unfold CRminus. rewrite CRopp_mult_distr_l. + rewrite <- CRmult_plus_distr_r. + apply (CRle_trans _ ((CR_of_Q R (1 # n * x)) * CRabs R a)). + rewrite CRabs_mult. apply CRmult_le_compat_r. apply CRabs_pos. + apply c0, H0. + setoid_replace (1 # n * x)%Q with ((1 # n) *(1# x))%Q. 2: reflexivity. + rewrite <- (CRmult_1_r (CR_of_Q R (1#n))). + rewrite CR_of_Q_mult, CRmult_assoc. + apply CRmult_le_compat_l. rewrite <- CR_of_Q_zero. + apply CR_of_Q_le. discriminate. intro abs. + apply (CRmult_lt_compat_l (CR_of_Q R (Z.pos x #1))) in abs. + rewrite CRmult_1_r, <- CRmult_assoc, <- CR_of_Q_mult in abs. + rewrite (CR_of_Q_morph R ((Z.pos x # 1) * (1 # x))%Q 1%Q) in abs. + rewrite CR_of_Q_one, CRmult_1_l in abs. + apply (CRlt_asym _ _ abs), (CRlt_trans _ (1 + CRabs R a)). + 2: exact c. rewrite <- CRplus_0_l, <- CRplus_assoc. + apply CRplus_lt_compat_r. rewrite CRplus_0_r. apply CRzero_lt_one. + unfold Qmult, Qeq, Qnum, Qden. ring_simplify. rewrite Pos.mul_1_l. + reflexivity. + apply (CRlt_trans _ (1+CRabs R a)). 2: exact c. + rewrite CRplus_comm. + rewrite <- (CRplus_0_r 0). apply CRplus_le_lt_compat. + apply CRabs_pos. apply CRzero_lt_one. +Qed. + +Lemma CR_cv_const : forall {R : ConstructiveReals} (a : CRcarrier R), + CR_cv R (fun n => a) a. +Proof. + intros a p. exists O. intros. + unfold CRminus. rewrite CRplus_opp_r. + rewrite CRabs_right. rewrite <- CR_of_Q_zero. + apply CR_of_Q_le. discriminate. apply CRle_refl. +Qed. + +Lemma Rcv_cauchy_mod : forall {R : ConstructiveReals} + (un : nat -> CRcarrier R) (l : CRcarrier R), + CR_cv R un l -> CR_cauchy R un. +Proof. + intros. intros p. specialize (H (2*p)%positive) as [k H]. + exists k. intros n q H0 H1. + setoid_replace (1#p)%Q with ((1#2*p) + (1#2*p))%Q. + rewrite CR_of_Q_plus. + setoid_replace (un n - un q) with ((un n - l) - (un q - l)). + apply (CRle_trans _ _ _ (CRabs_triang _ _)). + apply CRplus_le_compat. + - apply H, H0. + - rewrite CRabs_opp. apply H. apply H1. + - unfold CRminus. rewrite CRplus_assoc. apply CRplus_morph. + reflexivity. rewrite CRplus_comm, CRopp_plus_distr, CRopp_involutive. + rewrite CRplus_assoc, CRplus_opp_r, CRplus_0_r. reflexivity. + - rewrite Qinv_plus_distr. reflexivity. +Qed. + +Lemma series_cv_eq : forall {R : ConstructiveReals} + (u v : nat -> CRcarrier R) (s : CRcarrier R), + (forall n:nat, u n == v n) + -> series_cv u s + -> series_cv v s. +Proof. + intros. intros p. specialize (H0 p). destruct H0 as [N H0]. + exists N. intros. unfold CRminus. + rewrite <- (CRsum_eq u). apply H0, H1. intros. apply H. +Qed. + +Lemma CR_growing_transit : forall {R : ConstructiveReals} (un : nat -> CRcarrier R), + (forall n:nat, un n <= un (S n)) + -> forall n p : nat, le n p -> un n <= un p. +Proof. + induction p. + - intros. inversion H0. apply CRle_refl. + - intros. apply Nat.le_succ_r in H0. destruct H0. + apply (CRle_trans _ (un p)). apply IHp, H0. apply H. + subst n. apply CRle_refl. +Qed. + +Lemma growing_ineq : + forall {R : ConstructiveReals} (Un:nat -> CRcarrier R) (l:CRcarrier R), + (forall n:nat, Un n <= Un (S n)) + -> CR_cv R Un l -> forall n:nat, Un n <= l. +Proof. + intros. intro abs. + destruct (Un_cv_nat_real _ l H0 (Un n - l)) as [N H1]. + rewrite <- (CRplus_opp_r l). apply CRplus_lt_compat_r. exact abs. + specialize (H1 (max n N) (Nat.le_max_r _ _)). + apply (CRle_lt_trans _ _ _ (CRle_abs _)) in H1. + apply CRplus_lt_reg_r in H1. + apply (CR_growing_transit Un H n (max n N)). apply Nat.le_max_l. + exact H1. +Qed. + +Lemma CR_cv_open_below + : forall {R : ConstructiveReals} + (un : nat -> CRcarrier R) (m l : CRcarrier R), + CR_cv R un l + -> m < l + -> { n : nat & forall i:nat, le n i -> m < un i }. +Proof. + intros. apply CRlt_minus in H0. + pose proof (Un_cv_nat_real _ l H (l-m) H0) as [n nmaj]. + exists n. intros. specialize (nmaj i H1). + apply CRabs_lt in nmaj. + destruct nmaj as [_ nmaj]. unfold CRminus in nmaj. + rewrite CRopp_plus_distr, CRopp_involutive, CRplus_comm in nmaj. + apply CRplus_lt_reg_l in nmaj. + apply (CRplus_lt_reg_l R (-m)). rewrite CRplus_opp_l. + apply (CRplus_lt_reg_r (-un i)). rewrite CRplus_0_l. + rewrite CRplus_assoc, CRplus_opp_r, CRplus_0_r. exact nmaj. +Qed. + +Lemma CR_cv_open_above + : forall {R : ConstructiveReals} + (un : nat -> CRcarrier R) (m l : CRcarrier R), + CR_cv R un l + -> l < m + -> { n : nat & forall i:nat, le n i -> un i < m }. +Proof. + intros. apply CRlt_minus in H0. + pose proof (Un_cv_nat_real _ l H (m-l) H0) as [n nmaj]. + exists n. intros. specialize (nmaj i H1). + apply CRabs_lt in nmaj. + destruct nmaj as [nmaj _]. apply CRplus_lt_reg_r in nmaj. + exact nmaj. +Qed. + +Lemma CR_cv_bound_down : forall {R : ConstructiveReals} + (u : nat -> CRcarrier R) (A l : CRcarrier R) (N : nat), + (forall n:nat, le N n -> A <= u n) + -> CR_cv R u l + -> A <= l. +Proof. + intros. intro r. + apply (CRplus_lt_compat_r (-l)) in r. rewrite CRplus_opp_r in r. + destruct (Un_cv_nat_real _ l H0 (A - l) r) as [n H1]. + apply (H (n+N)%nat). + rewrite <- (plus_0_l N). rewrite Nat.add_assoc. + apply Nat.add_le_mono_r. apply le_0_n. + specialize (H1 (n+N)%nat). apply (CRplus_lt_reg_r (-l)). + assert (n + N >= n)%nat. rewrite <- (plus_0_r n). rewrite <- plus_assoc. + apply Nat.add_le_mono_l. apply le_0_n. specialize (H1 H2). + apply (CRle_lt_trans _ (CRabs R (u (n + N)%nat - l))). + apply CRle_abs. assumption. +Qed. + +Lemma CR_cv_bound_up : forall {R : ConstructiveReals} + (u : nat -> CRcarrier R) (A l : CRcarrier R) (N : nat), + (forall n:nat, le N n -> u n <= A) + -> CR_cv R u l + -> l <= A. +Proof. + intros. intro r. + apply (CRplus_lt_compat_r (-A)) in r. rewrite CRplus_opp_r in r. + destruct (Un_cv_nat_real _ l H0 (l-A) r) as [n H1]. + apply (H (n+N)%nat). + - rewrite <- (plus_0_l N). apply Nat.add_le_mono_r. apply le_0_n. + - specialize (H1 (n+N)%nat). apply (CRplus_lt_reg_l R (l - A - u (n+N)%nat)). + unfold CRminus. repeat rewrite CRplus_assoc. + rewrite CRplus_opp_l, CRplus_0_r, (CRplus_comm (-A)). + rewrite CRplus_assoc, CRplus_opp_r, CRplus_0_r. + apply (CRle_lt_trans _ _ _ (CRle_abs _)). + fold (l - u (n+N)%nat). rewrite CRabs_minus_sym. apply H1. + rewrite <- (plus_0_r n). rewrite <- plus_assoc. + apply Nat.add_le_mono_l. apply le_0_n. +Qed. + +Lemma series_cv_maj : forall {R : ConstructiveReals} + (un vn : nat -> CRcarrier R) (s : CRcarrier R), + (forall n:nat, CRabs R (un n) <= vn n) + -> series_cv vn s + -> { l : CRcarrier R & prod (series_cv un l) (l <= s) }. +Proof. + intros. destruct (CR_complete R (CRsum un)). + - intros n. + specialize (H0 (2*n)%positive) as [N maj]. + exists N. intros i j H0 H1. + apply (CRle_trans _ (CRsum vn (max i j) - CRsum vn (min i j))). + apply Abs_sum_maj. apply H. + setoid_replace (CRsum vn (max i j) - CRsum vn (min i j)) + with (CRabs R (CRsum vn (max i j) - (CRsum vn (min i j)))). + setoid_replace (CRsum vn (Init.Nat.max i j) - CRsum vn (Init.Nat.min i j)) + with (CRsum vn (Init.Nat.max i j) - s - (CRsum vn (Init.Nat.min i j) - s)). + apply (CRle_trans _ _ _ (CRabs_triang _ _)). + setoid_replace (1#n)%Q with ((1#2*n) + (1#2*n))%Q. + rewrite CR_of_Q_plus. + apply CRplus_le_compat. + apply maj. apply (le_trans _ i). assumption. apply Nat.le_max_l. + rewrite CRabs_opp. apply maj. + apply Nat.min_case. apply (le_trans _ i). assumption. apply le_refl. + assumption. rewrite Qinv_plus_distr. reflexivity. + unfold CRminus. rewrite CRplus_assoc. apply CRplus_morph. + reflexivity. rewrite CRopp_plus_distr, CRopp_involutive. + rewrite CRplus_comm, CRplus_assoc, CRplus_opp_r, CRplus_0_r. + reflexivity. + rewrite CRabs_right. reflexivity. + rewrite <- (CRplus_opp_r (CRsum vn (Init.Nat.min i j))). + apply CRplus_le_compat. apply pos_sum_more. + intros. apply (CRle_trans _ (CRabs R (un k))). apply CRabs_pos. + apply H. apply (le_trans _ i). apply Nat.le_min_l. apply Nat.le_max_l. + apply CRle_refl. + - exists x. split. assumption. + (* x <= s *) + apply (CRplus_le_reg_r (-x)). rewrite CRplus_opp_r. + apply (CR_cv_bound_down (fun n => CRsum vn n - CRsum un n) _ _ 0). + intros. rewrite <- (CRplus_opp_r (CRsum un n)). + apply CRplus_le_compat. apply sum_Rle. + intros. apply (CRle_trans _ (CRabs R (un k))). + apply CRle_abs. apply H. apply CRle_refl. + apply CR_cv_plus. assumption. + apply CR_cv_opp. assumption. +Qed. + +Lemma series_cv_abs_lt + : forall {R : ConstructiveReals} (un vn : nat -> CRcarrier R) (l : CRcarrier R), + (forall n:nat, CRabs R (un n) <= vn n) + -> series_cv_lim_lt vn l + -> series_cv_lim_lt un l. +Proof. + intros. destruct H0 as [x [H0 H1]]. + destruct (series_cv_maj un vn x H H0) as [x0 H2]. + exists x0. split. apply H2. apply (CRle_lt_trans _ x). + apply H2. apply H1. +Qed. + +Definition series_cv_abs {R : ConstructiveReals} (u : nat -> CRcarrier R) + : CR_cauchy R (CRsum (fun n => CRabs R (u n))) + -> { l : CRcarrier R & series_cv u l }. +Proof. + intros. apply CR_complete in H. destruct H. + destruct (series_cv_maj u (fun k => CRabs R (u k)) x). + intro n. apply CRle_refl. assumption. exists x0. apply p. +Qed. + +Lemma series_cv_abs_eq + : forall {R : ConstructiveReals} (u : nat -> CRcarrier R) (a : CRcarrier R) + (cau : CR_cauchy R (CRsum (fun n => CRabs R (u n)))), + series_cv u a + -> (a == (let (l,_):= series_cv_abs u cau in l))%ConstructiveReals. +Proof. + intros. destruct (series_cv_abs u cau). + apply (series_cv_unique u). exact H. exact s. +Qed. + +Lemma series_cv_abs_cv + : forall {R : ConstructiveReals} (u : nat -> CRcarrier R) + (cau : CR_cauchy R (CRsum (fun n => CRabs R (u n)))), + series_cv u (let (l,_):= series_cv_abs u cau in l). +Proof. + intros. destruct (series_cv_abs u cau). exact s. +Qed. + +Lemma series_cv_opp : forall {R : ConstructiveReals} + (s : CRcarrier R) (u : nat -> CRcarrier R), + series_cv u s + -> series_cv (fun n => - u n) (- s). +Proof. + intros. intros p. specialize (H p) as [N H]. + exists N. intros n H0. + setoid_replace (CRsum (fun n0 : nat => - u n0) n - - s) + with (-(CRsum (fun n0 : nat => u n0) n - s)). + rewrite CRabs_opp. + apply H, H0. unfold CRminus. + rewrite sum_opp. rewrite CRopp_plus_distr. reflexivity. +Qed. + +Lemma series_cv_scale : forall {R : ConstructiveReals} + (a : CRcarrier R) (s : CRcarrier R) (u : nat -> CRcarrier R), + series_cv u s + -> series_cv (fun n => (u n) * a) (s * a). +Proof. + intros. + apply (CR_cv_eq _ (fun n => CRsum u n * a)). + intro n. rewrite sum_scale. reflexivity. apply CR_cv_scale, H. +Qed. + +Lemma series_cv_plus : forall {R : ConstructiveReals} + (u v : nat -> CRcarrier R) (s t : CRcarrier R), + series_cv u s + -> series_cv v t + -> series_cv (fun n => u n + v n) (s + t). +Proof. + intros. apply (CR_cv_eq _ (fun n => CRsum u n + CRsum v n)). + intro n. symmetry. apply sum_plus. apply CR_cv_plus. exact H. exact H0. +Qed. + +Lemma series_cv_nonneg : forall {R : ConstructiveReals} + (u : nat -> CRcarrier R) (s : CRcarrier R), + (forall n:nat, 0 <= u n) -> series_cv u s -> 0 <= s. +Proof. + intros. apply (CRle_trans 0 (CRsum u 0)). apply H. + apply (growing_ineq (CRsum u)). intro n. simpl. + rewrite <- CRplus_0_r. apply CRplus_le_compat. + rewrite CRplus_0_r. apply CRle_refl. apply H. apply H0. +Qed. + +Lemma CR_cv_le : forall {R : ConstructiveReals} + (u v : nat -> CRcarrier R) (a b : CRcarrier R), + (forall n:nat, u n <= v n) + -> CR_cv R u a + -> CR_cv R v b + -> a <= b. +Proof. + intros. apply (CRplus_le_reg_r (-a)). rewrite CRplus_opp_r. + apply (CR_cv_bound_down (fun i:nat => v i - u i) _ _ 0). + intros. rewrite <- (CRplus_opp_l (u n)). + unfold CRminus. + rewrite (CRplus_comm (v n)). apply CRplus_le_compat_l. + apply H. apply CR_cv_plus. exact H1. apply CR_cv_opp, H0. +Qed. + +Lemma CR_cv_abs_cont : forall {R : ConstructiveReals} + (u : nat -> CRcarrier R) (s : CRcarrier R), + CR_cv R u s + -> CR_cv R (fun n => CRabs R (u n)) (CRabs R s). +Proof. + intros. intros eps. specialize (H eps) as [N lim]. + exists N. intros n H. + apply (CRle_trans _ (CRabs R (u n - s))). apply CRabs_triang_inv2. + apply lim. assumption. +Qed. + +Lemma CR_cv_dist_cont : forall {R : ConstructiveReals} + (u : nat -> CRcarrier R) (a s : CRcarrier R), + CR_cv R u s + -> CR_cv R (fun n => CRabs R (a - u n)) (CRabs R (a - s)). +Proof. + intros. apply CR_cv_abs_cont. + intros eps. specialize (H eps) as [N lim]. + exists N. intros n H. + setoid_replace (a - u n - (a - s)) with (s - (u n)). + specialize (lim n). + rewrite CRabs_minus_sym. + apply lim. assumption. + unfold CRminus. rewrite CRopp_plus_distr, CRopp_involutive. + rewrite (CRplus_comm a), (CRplus_comm s). + rewrite CRplus_assoc. apply CRplus_morph. reflexivity. + rewrite <- CRplus_assoc, CRplus_opp_r, CRplus_0_l. reflexivity. +Qed. + +Lemma series_cv_triangle : forall {R : ConstructiveReals} + (u : nat -> CRcarrier R) (s sAbs : CRcarrier R), + series_cv u s + -> series_cv (fun n => CRabs R (u n)) sAbs + -> CRabs R s <= sAbs. +Proof. + intros. + apply (CR_cv_le (fun n => CRabs R (CRsum u n)) + (CRsum (fun n => CRabs R (u n)))). + intros. apply multiTriangleIneg. apply CR_cv_abs_cont. assumption. assumption. +Qed. + +Lemma CR_double : forall {R : ConstructiveReals} (x:CRcarrier R), + CR_of_Q R 2 * x == x + x. +Proof. + intros R x. rewrite (CR_of_Q_morph R 2 (1+1)). + 2: reflexivity. rewrite CR_of_Q_plus, CR_of_Q_one. + rewrite CRmult_plus_distr_r, CRmult_1_l. reflexivity. +Qed. + +Lemma GeoCvZero : forall {R : ConstructiveReals}, + CR_cv R (fun n:nat => CRpow (CR_of_Q R (1#2)) n) 0. +Proof. + intro R. assert (forall n:nat, INR n < CRpow (CR_of_Q R 2) n). + { induction n. unfold INR; simpl. rewrite CR_of_Q_zero. + apply CRzero_lt_one. unfold INR. fold (1+n)%nat. + rewrite Nat2Z.inj_add. + rewrite (CR_of_Q_morph R _ ((Z.of_nat 1 # 1) + (Z.of_nat n #1))). + 2: symmetry; apply Qinv_plus_distr. + rewrite CR_of_Q_plus. + replace (CRpow (CR_of_Q R 2) (1 + n)) + with (CR_of_Q R 2 * CRpow (CR_of_Q R 2) n). + 2: reflexivity. rewrite CR_double. + apply CRplus_le_lt_compat. + 2: exact IHn. simpl. rewrite CR_of_Q_one. + apply pow_R1_Rle. rewrite <- CR_of_Q_one. apply CR_of_Q_le. discriminate. } + intros p. exists (Pos.to_nat p). intros. + unfold CRminus. rewrite CRopp_0. rewrite CRplus_0_r. + rewrite CRabs_right. + 2: apply pow_le; rewrite <- CR_of_Q_zero; apply CR_of_Q_le; discriminate. + apply CRlt_asym. + apply (CRmult_lt_reg_l (CR_of_Q R (Z.pos p # 1))). + rewrite <- CR_of_Q_zero. apply CR_of_Q_lt. reflexivity. rewrite <- CR_of_Q_mult. + rewrite (CR_of_Q_morph R ((Z.pos p # 1) * (1 # p)) 1). + 2: unfold Qmult, Qeq, Qnum, Qden; ring_simplify; reflexivity. + apply (CRmult_lt_reg_r (CRpow (CR_of_Q R 2) i)). + apply pow_lt. simpl. rewrite <- CR_of_Q_zero. + apply CR_of_Q_lt. reflexivity. + rewrite CRmult_assoc. rewrite pow_mult. + rewrite (pow_proper (CR_of_Q R (1 # 2) * CR_of_Q R 2) 1), pow_one. + rewrite CRmult_1_r, CR_of_Q_one, CRmult_1_l. + apply (CRle_lt_trans _ (INR i)). 2: exact (H i). clear H. + apply CR_of_Q_le. unfold Qle,Qnum,Qden. + do 2 rewrite Z.mul_1_r. + rewrite <- positive_nat_Z. apply Nat2Z.inj_le, H0. + rewrite <- CR_of_Q_mult. setoid_replace ((1#2)*2)%Q with 1%Q. + apply CR_of_Q_one. reflexivity. +Qed. + +Lemma GeoFiniteSum : forall {R : ConstructiveReals} (n:nat), + CRsum (CRpow (CR_of_Q R (1#2))) n == CR_of_Q R 2 - CRpow (CR_of_Q R (1#2)) n. +Proof. + induction n. + - unfold CRsum, CRpow. simpl (1%ConstructiveReals). + unfold CRminus. rewrite (CR_of_Q_morph R _ (1+1)). + rewrite CR_of_Q_plus, CR_of_Q_one, CRplus_assoc. + rewrite CRplus_opp_r, CRplus_0_r. reflexivity. reflexivity. + - setoid_replace (CRsum (CRpow (CR_of_Q R (1 # 2))) (S n)) + with (CRsum (CRpow (CR_of_Q R (1 # 2))) n + CRpow (CR_of_Q R (1 # 2)) (S n)). + 2: reflexivity. + rewrite IHn. clear IHn. unfold CRminus. + rewrite CRplus_assoc. apply CRplus_morph. reflexivity. + apply (CRplus_eq_reg_l + (CRpow (CR_of_Q R (1 # 2)) n + CRpow (CR_of_Q R (1 # 2)) (S n))). + rewrite (CRplus_assoc _ _ (-CRpow (CR_of_Q R (1 # 2)) (S n))), + CRplus_opp_r, CRplus_0_r. + rewrite (CRplus_comm (CRpow (CR_of_Q R (1 # 2)) n)), CRplus_assoc. + rewrite <- (CRplus_assoc (CRpow (CR_of_Q R (1 # 2)) n)), CRplus_opp_r, + CRplus_0_l, <- CR_double. + setoid_replace (CRpow (CR_of_Q R (1 # 2)) (S n)) + with (CR_of_Q R (1 # 2) * CRpow (CR_of_Q R (1 # 2)) n). + 2: reflexivity. + rewrite <- CRmult_assoc, <- CR_of_Q_mult. + setoid_replace (2 * (1 # 2))%Q with 1%Q. + rewrite CR_of_Q_one. apply CRmult_1_l. reflexivity. +Qed. + +Lemma GeoHalfBelowTwo : forall {R : ConstructiveReals} (n:nat), + CRsum (CRpow (CR_of_Q R (1#2))) n < CR_of_Q R 2. +Proof. + intros. rewrite <- (CRplus_0_r (CR_of_Q R 2)), GeoFiniteSum. + apply CRplus_lt_compat_l. rewrite <- CRopp_0. + apply CRopp_gt_lt_contravar. + apply pow_lt. rewrite <- CR_of_Q_zero. apply CR_of_Q_lt. reflexivity. +Qed. + +Lemma GeoHalfTwo : forall {R : ConstructiveReals}, + series_cv (fun n => CRpow (CR_of_Q R (1#2)) n) (CR_of_Q R 2). +Proof. + intro R. + apply (CR_cv_eq _ (fun n => CR_of_Q R 2 - CRpow (CR_of_Q R (1 # 2)) n)). + - intro n. rewrite GeoFiniteSum. reflexivity. + - assert (forall n:nat, INR n < CRpow (CR_of_Q R 2) n). + { induction n. unfold INR; simpl. rewrite CR_of_Q_zero. + apply CRzero_lt_one. apply (CRlt_le_trans _ (CRpow (CR_of_Q R 2) n + 1)). + unfold INR. + rewrite Nat2Z.inj_succ, <- Z.add_1_l. + rewrite (CR_of_Q_morph R _ (1 + (Z.of_nat n #1))). + 2: symmetry; apply Qinv_plus_distr. rewrite CR_of_Q_plus. + rewrite CRplus_comm. rewrite CR_of_Q_one. + apply CRplus_lt_compat_r, IHn. + setoid_replace (CRpow (CR_of_Q R 2) (S n)) + with (CRpow (CR_of_Q R 2) n + CRpow (CR_of_Q R 2) n). + apply CRplus_le_compat. apply CRle_refl. + apply pow_R1_Rle. rewrite <- CR_of_Q_one. apply CR_of_Q_le. discriminate. + rewrite <- CR_double. reflexivity. } + intros n. exists (Pos.to_nat n). intros. + setoid_replace (CR_of_Q R 2 - CRpow (CR_of_Q R (1 # 2)) i - CR_of_Q R 2) + with (- CRpow (CR_of_Q R (1 # 2)) i). + rewrite CRabs_opp. rewrite CRabs_right. + assert (0 < CR_of_Q R 2). + { rewrite <- CR_of_Q_zero. apply CR_of_Q_lt. reflexivity. } + rewrite (pow_proper _ (CRinv R (CR_of_Q R 2) (inr H1))). + rewrite pow_inv. apply CRlt_asym. + apply (CRmult_lt_reg_l (CRpow (CR_of_Q R 2) i)). apply pow_lt, H1. + rewrite CRinv_r. + apply (CRmult_lt_reg_r (CR_of_Q R (Z.pos n#1))). + rewrite <- CR_of_Q_zero. apply CR_of_Q_lt. reflexivity. + rewrite CRmult_1_l, CRmult_assoc. + rewrite <- CR_of_Q_mult. + rewrite (CR_of_Q_morph R ((1 # n) * (Z.pos n # 1)) 1). 2: reflexivity. + rewrite CR_of_Q_one, CRmult_1_r. apply (CRle_lt_trans _ (INR i)). + 2: apply H. apply CR_of_Q_le. + unfold Qle, Qnum, Qden. do 2 rewrite Z.mul_1_r. destruct i. + exfalso. inversion H0. pose proof (Pos2Nat.is_pos n). + rewrite H3 in H2. inversion H2. + apply Pos2Z.pos_le_pos. apply Pos2Nat.inj_le. + apply (le_trans _ _ _ H0). rewrite SuccNat2Pos.id_succ. apply le_refl. + apply (CRmult_eq_reg_l (CR_of_Q R 2)). right. exact H1. + rewrite CRinv_r. rewrite <- CR_of_Q_mult. + setoid_replace (2 * (1 # 2))%Q with 1%Q. + apply CR_of_Q_one. reflexivity. + apply CRlt_asym, pow_lt. rewrite <- CR_of_Q_zero. + apply CR_of_Q_lt. reflexivity. + unfold CRminus. rewrite CRplus_comm, <- CRplus_assoc. + rewrite CRplus_opp_l, CRplus_0_l. reflexivity. +Qed. + +Lemma series_cv_remainder_maj : forall {R : ConstructiveReals} (u : nat -> CRcarrier R) + (s eps : CRcarrier R) + (N : nat), + series_cv u s + -> 0 < eps + -> (forall n:nat, 0 <= u n) + -> CRabs R (CRsum u N - s) <= eps + -> forall n:nat, CRsum (fun k=> u (N + S k)%nat) n <= eps. +Proof. + intros. pose proof (sum_assoc u N n). + rewrite <- (CRsum_eq (fun k : nat => u (S N + k)%nat)). + apply (CRplus_le_reg_l (CRsum u N)). rewrite <- H3. + apply (CRle_trans _ s). apply growing_ineq. + 2: apply H. + intro k. simpl. rewrite <- CRplus_0_r, CRplus_assoc. + apply CRplus_le_compat_l. rewrite CRplus_0_l. apply H1. + rewrite CRabs_minus_sym in H2. + rewrite CRplus_comm. apply (CRplus_le_reg_r (-CRsum u N)). + rewrite CRplus_assoc. rewrite CRplus_opp_r. rewrite CRplus_0_r. + apply (CRle_trans _ (CRabs R (s - CRsum u N))). apply CRle_abs. + assumption. intros. rewrite Nat.add_succ_r. reflexivity. +Qed. + +Lemma series_cv_abs_remainder : forall {R : ConstructiveReals} (u : nat -> CRcarrier R) + (s sAbs : CRcarrier R) + (n : nat), + series_cv u s + -> series_cv (fun n => CRabs R (u n)) sAbs + -> CRabs R (CRsum u n - s) + <= sAbs - CRsum (fun n => CRabs R (u n)) n. +Proof. + intros. + apply (CR_cv_le (fun N => CRabs R (CRsum u n - (CRsum u (n + N)))) + (fun N => CRsum (fun n : nat => CRabs R (u n)) (n + N) + - CRsum (fun n : nat => CRabs R (u n)) n)). + - intro N. destruct N. rewrite plus_0_r. unfold CRminus. + rewrite CRplus_opp_r. rewrite CRplus_opp_r. + rewrite CRabs_right. apply CRle_refl. apply CRle_refl. + rewrite Nat.add_succ_r. + replace (S (n + N)) with (S n + N)%nat. 2: reflexivity. + unfold CRminus. rewrite sum_assoc. rewrite sum_assoc. + rewrite CRopp_plus_distr. + rewrite <- CRplus_assoc, CRplus_opp_r, CRplus_0_l, CRabs_opp. + rewrite CRplus_comm, <- CRplus_assoc, CRplus_opp_l. + rewrite CRplus_0_l. apply multiTriangleIneg. + - apply CR_cv_dist_cont. intros eps. + specialize (H eps) as [N lim]. + exists N. intros. rewrite plus_comm. apply lim. apply (le_trans N i). + assumption. rewrite <- (plus_0_r i). rewrite <- plus_assoc. + apply Nat.add_le_mono_l. apply le_0_n. + - apply CR_cv_plus. 2: apply CR_cv_const. intros eps. + specialize (H0 eps) as [N lim]. + exists N. intros. rewrite plus_comm. apply lim. apply (le_trans N i). + assumption. rewrite <- (plus_0_r i). rewrite <- plus_assoc. + apply Nat.add_le_mono_l. apply le_0_n. +Qed. + +Lemma series_cv_minus : forall {R : ConstructiveReals} + (u v : nat -> CRcarrier R) (s t : CRcarrier R), + series_cv u s + -> series_cv v t + -> series_cv (fun n => u n - v n) (s - t). +Proof. + intros. apply (CR_cv_eq _ (fun n => CRsum u n - CRsum v n)). + intro n. symmetry. unfold CRminus. rewrite sum_plus. + rewrite sum_opp. reflexivity. + apply CR_cv_plus. exact H. apply CR_cv_opp. exact H0. +Qed. + +Lemma series_cv_le : forall {R : ConstructiveReals} + (un vn : nat -> CRcarrier R) (a b : CRcarrier R), + (forall n:nat, un n <= vn n) + -> series_cv un a + -> series_cv vn b + -> a <= b. +Proof. + intros. apply (CRplus_le_reg_r (-a)). rewrite CRplus_opp_r. + apply (series_cv_nonneg (fun n => vn n - un n)). + intro n. apply (CRplus_le_reg_r (un n)). + rewrite CRplus_0_l. unfold CRminus. + rewrite CRplus_assoc, CRplus_opp_l, CRplus_0_r. + apply H. apply series_cv_minus; assumption. +Qed. + +Lemma series_cv_series : forall {R : ConstructiveReals} + (u : nat -> nat -> CRcarrier R) (s : nat -> CRcarrier R) (n : nat), + (forall i:nat, le i n -> series_cv (u i) (s i)) + -> series_cv (fun i => CRsum (fun j => u j i) n) (CRsum s n). +Proof. + induction n. + - intros. simpl. specialize (H O). + apply (series_cv_eq (u O)). reflexivity. apply H. apply le_refl. + - intros. simpl. apply (series_cv_plus). 2: apply (H (S n)). + apply IHn. 2: apply le_refl. intros. apply H. + apply (le_trans _ n _ H0). apply le_S. apply le_refl. +Qed. + +Lemma CR_cv_shift : + forall {R : ConstructiveReals} f k l, + CR_cv R (fun n => f (n + k)%nat) l -> CR_cv R f l. +Proof. + intros. intros eps. + specialize (H eps) as [N Nmaj]. + exists (N+k)%nat. intros n H. + destruct (Nat.le_exists_sub k n). + apply (le_trans _ (N + k)). 2: exact H. + apply (le_trans _ (0 + k)). apply le_refl. + rewrite <- Nat.add_le_mono_r. apply le_0_n. + destruct H0. + subst n. apply Nmaj. unfold ge in H. + rewrite <- Nat.add_le_mono_r in H. exact H. +Qed. + +Lemma CR_cv_shift' : + forall {R : ConstructiveReals} f k l, + CR_cv R f l -> CR_cv R (fun n => f (n + k)%nat) l. +Proof. + intros R f' k l cvf eps; destruct (cvf eps) as [N Pn]. + exists N; intros n nN; apply Pn; auto with arith. +Qed. + +Lemma series_cv_shift : + forall {R : ConstructiveReals} (f : nat -> CRcarrier R) k l, + series_cv (fun n => f (S k + n)%nat) l + -> series_cv f (l + CRsum f k). +Proof. + intros. intro p. specialize (H p) as [n nmaj]. + exists (S k+n)%nat. intros. destruct (Nat.le_exists_sub (S k) i). + apply (le_trans _ (S k + 0)). rewrite Nat.add_0_r. apply le_refl. + apply (le_trans _ (S k + n)). apply Nat.add_le_mono_l, le_0_n. + exact H. destruct H0. subst i. + rewrite Nat.add_comm in H. rewrite <- Nat.add_le_mono_r in H. + specialize (nmaj x H). unfold CRminus. + rewrite Nat.add_comm, (sum_assoc f k x). + setoid_replace (CRsum f k + CRsum (fun k0 : nat => f (S k + k0)%nat) x - (l + CRsum f k)) + with (CRsum (fun k0 : nat => f (S k + k0)%nat) x - l). + exact nmaj. unfold CRminus. rewrite (CRplus_comm (CRsum f k)). + rewrite CRplus_assoc. apply CRplus_morph. reflexivity. + rewrite CRplus_comm, CRopp_plus_distr, CRplus_assoc. + rewrite CRplus_opp_l, CRplus_0_r. reflexivity. +Qed. + +Lemma series_cv_shift' : forall {R : ConstructiveReals} + (un : nat -> CRcarrier R) (s : CRcarrier R) (shift : nat), + series_cv un s + -> series_cv (fun n => un (n+shift)%nat) + (s - match shift with + | O => 0 + | S p => CRsum un p + end). +Proof. + intros. destruct shift as [|p]. + - unfold CRminus. rewrite CRopp_0. rewrite CRplus_0_r. + apply (series_cv_eq un). intros. + rewrite plus_0_r. reflexivity. apply H. + - apply (CR_cv_eq _ (fun n => CRsum un (n + S p) - CRsum un p)). + intros. rewrite plus_comm. unfold CRminus. + rewrite sum_assoc. simpl. rewrite CRplus_comm, <- CRplus_assoc. + rewrite CRplus_opp_l, CRplus_0_l. + apply CRsum_eq. intros. rewrite (plus_comm i). reflexivity. + apply CR_cv_plus. apply (CR_cv_shift' _ (S p) _ H). + intros n. exists (Pos.to_nat n). intros. + unfold CRminus. simpl. + rewrite CRopp_involutive, CRplus_opp_l. rewrite CRabs_right. + rewrite <- CR_of_Q_zero. apply CR_of_Q_le. discriminate. apply CRle_refl. +Qed. diff --git a/theories/Reals/Abstract/ConstructiveReals.v b/theories/Reals/Abstract/ConstructiveReals.v new file mode 100644 index 0000000000..d91fd1183a --- /dev/null +++ b/theories/Reals/Abstract/ConstructiveReals.v @@ -0,0 +1,1149 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) +(************************************************************************) + +(** An interface for constructive and computable real numbers. + All of its instances are isomorphic (see file ConstructiveRealsMorphisms). + For example it is implemented by the Cauchy reals in file + ConstructivecauchyReals and also implemented by the sumbool-based + Dedekind reals defined by + +Structure R := { + (* The cuts are represented as propositional functions, rather than subsets, + as there are no subsets in type theory. *) + lower : Q -> Prop; + upper : Q -> Prop; + (* The cuts respect equality on Q. *) + lower_proper : Proper (Qeq ==> iff) lower; + upper_proper : Proper (Qeq ==> iff) upper; + (* The cuts are inhabited. *) + lower_bound : { q : Q | lower q }; + upper_bound : { r : Q | upper r }; + (* The lower cut is a lower set. *) + lower_lower : forall q r, q < r -> lower r -> lower q; + (* The lower cut is open. *) + lower_open : forall q, lower q -> exists r, q < r /\ lower r; + (* The upper cut is an upper set. *) + upper_upper : forall q r, q < r -> upper q -> upper r; + (* The upper cut is open. *) + upper_open : forall r, upper r -> exists q, q < r /\ upper q; + (* The cuts are disjoint. *) + disjoint : forall q, ~ (lower q /\ upper q); + (* There is no gap between the cuts. *) + located : forall q r, q < r -> { lower q } + { upper r } +}. + + see github.com/andrejbauer/dedekind-reals for the Prop-based + version of those Dedekind reals (although Prop fails to make + them an instance of ConstructiveReals). + + Any computation about constructive reals can be worked + in the fastest instance for it; we then transport the results + to all other instances by the isomorphisms. This way of working + is different from the usual interfaces, where we would rather + prove things abstractly, by quantifying universally on the instance. + + The functions of ConstructiveReals do not have a direct impact + on performance, because algorithms will be extracted from instances, + and because fast ConstructiveReals morphisms should be coded + manually. However, since instances are forced to implement + those functions, it is probable that they will also use them + in their algorithms. So those functions hint at what we think + will yield fast and small extracted programs. + + Constructive reals are setoids, which custom equality is defined as + x == y iff (x <= y /\ y <= x). + It is hard to quotient constructively to get the Leibniz equality + on the real numbers. In "Sheaves in Geometry and Logic", + MacLane and Moerdijk show a topos in which all functions R -> Z + are constant. Consequently all functions R -> Q are constant and + it is not possible to approximate real numbers by rational numbers. *) + + +Require Import QArith Qabs Qround. + +Definition isLinearOrder {X : Set} (Xlt : X -> X -> Set) : Set + := (forall x y:X, Xlt x y -> Xlt y x -> False) + * (forall x y z : X, Xlt x y -> Xlt y z -> Xlt x z) + * (forall x y z : X, Xlt x z -> Xlt x y + Xlt y z). + +Structure ConstructiveReals : Type := + { + CRcarrier : Set; + + (* Put this order relation in sort Set rather than Prop, + to allow the definition of fast ConstructiveReals morphisms. + For example, the Cauchy reals do store information in + the proofs of CRlt, which is used in algorithms in sort Set. *) + CRlt : CRcarrier -> CRcarrier -> Set; + CRltLinear : isLinearOrder CRlt; + + CRle (x y : CRcarrier) := CRlt y x -> False; + CReq (x y : CRcarrier) := CRle y x /\ CRle x y; + CRapart (x y : CRcarrier) := sum (CRlt x y) (CRlt y x); + + (* The propositional truncation of CRlt. It facilitates proofs + when computations are not considered important, for example in + classical reals with extra logical axioms. *) + CRltProp : CRcarrier -> CRcarrier -> Prop; + (* This choice algorithm can be slow, keep it for the classical + quotient of the reals, where computations are blocked by + axioms like LPO. *) + CRltEpsilon : forall x y : CRcarrier, CRltProp x y -> CRlt x y; + CRltForget : forall x y : CRcarrier, CRlt x y -> CRltProp x y; + CRltDisjunctEpsilon : forall a b c d : CRcarrier, + (CRltProp a b \/ CRltProp c d) -> CRlt a b + CRlt c d; + + (* Constants *) + CRzero : CRcarrier; + CRone : CRcarrier; + + (* Addition and multiplication *) + CRplus : CRcarrier -> CRcarrier -> CRcarrier; + CRopp : CRcarrier -> CRcarrier; (* Computable opposite, + stronger than Prop-existence of opposite *) + CRmult : CRcarrier -> CRcarrier -> CRcarrier; + + CRisRing : ring_theory CRzero CRone CRplus CRmult + (fun x y => CRplus x (CRopp y)) CRopp CReq; + CRisRingExt : ring_eq_ext CRplus CRmult CRopp CReq; + + (* Compatibility with order *) + CRzero_lt_one : CRlt CRzero CRone; (* 0 # 1 would only allow 0 < 1 because + of Fmult_lt_0_compat so request 0 < 1 directly. *) + CRplus_lt_compat_l : forall r r1 r2 : CRcarrier, + CRlt r1 r2 -> CRlt (CRplus r r1) (CRplus r r2); + CRplus_lt_reg_l : forall r r1 r2 : CRcarrier, + CRlt (CRplus r r1) (CRplus r r2) -> CRlt r1 r2; + CRmult_lt_0_compat : forall x y : CRcarrier, + CRlt CRzero x -> CRlt CRzero y -> CRlt CRzero (CRmult x y); + + (* A constructive total inverse function on F would need to be continuous, + which is impossible because we cannot connect plus and minus infinities. + Therefore it has to be a partial function, defined on non zero elements. + For this reason we cannot use Coq's field_theory and field tactic. + + To implement Finv by Cauchy sequences we need orderAppart, + ~orderEq is not enough. *) + CRinv : forall x : CRcarrier, CRapart x CRzero -> CRcarrier; + CRinv_l : forall (r:CRcarrier) (rnz : CRapart r CRzero), + CReq (CRmult (CRinv r rnz) r) CRone; + CRinv_0_lt_compat : forall (r : CRcarrier) (rnz : CRapart r CRzero), + CRlt CRzero r -> CRlt CRzero (CRinv r rnz); + + (* The initial field morphism (in characteristic zero). + The abstract definition by iteration of addition is + probably the slowest. Let each instance implement + a faster (and often simpler) version. *) + CR_of_Q : Q -> CRcarrier; + CR_of_Q_plus : forall q r : Q, CReq (CR_of_Q (q+r)) + (CRplus (CR_of_Q q) (CR_of_Q r)); + CR_of_Q_mult : forall q r : Q, CReq (CR_of_Q (q*r)) + (CRmult (CR_of_Q q) (CR_of_Q r)); + CR_of_Q_one : CReq (CR_of_Q 1) CRone; + CR_of_Q_lt : forall q r : Q, + Qlt q r -> CRlt (CR_of_Q q) (CR_of_Q r); + lt_CR_of_Q : forall q r : Q, + CRlt (CR_of_Q q) (CR_of_Q r) -> Qlt q r; + + (* This function is very fast in both the Cauchy and Dedekind + instances, because this rational number q is almost what + the proof of CRlt x y contains. + This function is also the heart of the computation of + constructive real numbers : it approximates x to any + requested precision y. *) + CR_Q_dense : forall x y : CRcarrier, CRlt x y -> + { q : Q & prod (CRlt x (CR_of_Q q)) + (CRlt (CR_of_Q q) y) }; + CR_archimedean : forall x : CRcarrier, + { n : positive & CRlt x (CR_of_Q (Z.pos n # 1)) }; + + CRminus (x y : CRcarrier) : CRcarrier + := CRplus x (CRopp y); + + (* Absolute value, CRabs x is the least upper bound + of the pair x, -x. *) + CRabs : CRcarrier -> CRcarrier; + CRabs_def : forall x y : CRcarrier, + (CRle x y /\ CRle (CRopp x) y) + <-> CRle (CRabs x) y; + + (* Definitions of convergence and Cauchy-ness. The formulas + with orderLe or CRlt are logically equivalent, the choice of + orderLe in sort Prop is a question of performance. + It is very rare to turn back to the strict order to + define functions in sort Set, so we prefer to discard + those proofs during extraction. And even in those rare cases, + it is easy to divide epsilon by 2 for example. *) + CR_cv (un : nat -> CRcarrier) (l : CRcarrier) : Set + := forall p:positive, + { n : nat | forall i:nat, le n i + -> CRle (CRabs (CRminus (un i) l)) + (CR_of_Q (1#p)) }; + CR_cauchy (un : nat -> CRcarrier) : Set + := forall p : positive, + { n : nat | forall i j:nat, le n i -> le n j + -> CRle (CRabs (CRminus (un i) (un j))) + (CR_of_Q (1#p)) }; + + (* For the Cauchy reals, this algorithm consists in building + a Cauchy sequence of rationals un : nat -> Q that has + the same limit as xn. For each n:nat, un n is a 1/n + rational approximation of a point of xn that has converged + within 1/n. *) + CR_complete : + forall xn : (nat -> CRcarrier), + CR_cauchy xn -> { l : CRcarrier & CR_cv xn l }; + }. + +Declare Scope ConstructiveReals. + +Delimit Scope ConstructiveReals with ConstructiveReals. + +Notation "x < y" := (CRlt _ x y) : ConstructiveReals. +Notation "x <= y" := (CRle _ x y) : ConstructiveReals. +Notation "x <= y <= z" := (CRle _ x y /\ CRle _ y z) : ConstructiveReals. +Notation "x < y < z" := (prod (CRlt _ x y) (CRlt _ y z)) : ConstructiveReals. +Notation "x == y" := (CReq _ x y) : ConstructiveReals. +Notation "x ≶ y" := (CRapart _ x y) (at level 70, no associativity) : ConstructiveReals. +Notation "0" := (CRzero _) : ConstructiveReals. +Notation "1" := (CRone _) : ConstructiveReals. +Notation "x + y" := (CRplus _ x y) : ConstructiveReals. +Notation "- x" := (CRopp _ x) : ConstructiveReals. +Notation "x - y" := (CRminus _ x y) : ConstructiveReals. +Notation "x * y" := (CRmult _ x y) : ConstructiveReals. +Notation "/ x" := (CRinv _ x) : ConstructiveReals. + +Local Open Scope ConstructiveReals. + +Lemma CRlt_asym : forall {R : ConstructiveReals} (x y : CRcarrier R), + x < y -> x <= y. +Proof. + intros. intro H0. destruct (CRltLinear R), p. + apply (f x y); assumption. +Qed. + +Lemma CRlt_proper + : forall R : ConstructiveReals, + CMorphisms.Proper + (CMorphisms.respectful (CReq R) + (CMorphisms.respectful (CReq R) CRelationClasses.iffT)) (CRlt R). +Proof. + intros R x y H x0 y0 H0. destruct H, H0. + destruct (CRltLinear R). split. + - intro. destruct (s x y x0). assumption. + contradiction. destruct (s y y0 x0). + assumption. assumption. contradiction. + - intro. destruct (s y x y0). assumption. + contradiction. destruct (s x x0 y0). + assumption. assumption. contradiction. +Qed. + +Lemma CRle_refl : forall {R : ConstructiveReals} (x : CRcarrier R), + x <= x. +Proof. + intros. intro H. destruct (CRltLinear R), p. + exact (f x x H H). +Qed. + +Lemma CRle_lt_trans : forall {R : ConstructiveReals} (r1 r2 r3 : CRcarrier R), + r1 <= r2 -> r2 < r3 -> r1 < r3. +Proof. + intros. destruct (CRltLinear R). + destruct (s r2 r1 r3 H0). contradiction. apply c. +Qed. + +Lemma CRlt_le_trans : forall {R : ConstructiveReals} (r1 r2 r3 : CRcarrier R), + r1 < r2 -> r2 <= r3 -> r1 < r3. +Proof. + intros. destruct (CRltLinear R). + destruct (s r1 r3 r2 H). apply c. contradiction. +Qed. + +Lemma CRle_trans : forall {R : ConstructiveReals} (x y z : CRcarrier R), + x <= y -> y <= z -> x <= z. +Proof. + intros. intro abs. apply H0. + apply (CRlt_le_trans _ x); assumption. +Qed. + +Lemma CRlt_trans : forall {R : ConstructiveReals} (x y z : CRcarrier R), + x < y -> y < z -> x < z. +Proof. + intros. apply (CRlt_le_trans _ y _ H). + apply CRlt_asym. exact H0. +Defined. + +Lemma CRlt_trans_flip : forall {R : ConstructiveReals} (x y z : CRcarrier R), + y < z -> x < y -> x < z. +Proof. + intros. apply (CRlt_le_trans _ y). exact H0. + apply CRlt_asym. exact H. +Defined. + +Lemma CReq_refl : forall {R : ConstructiveReals} (x : CRcarrier R), + x == x. +Proof. + split; apply CRle_refl. +Qed. + +Lemma CReq_sym : forall {R : ConstructiveReals} (x y : CRcarrier R), + x == y -> y == x. +Proof. + intros. destruct H. split; intro abs; contradiction. +Qed. + +Lemma CReq_trans : forall {R : ConstructiveReals} (x y z : CRcarrier R), + x == y -> y == z -> x == z. +Proof. + intros. destruct H,H0. destruct (CRltLinear R), p. split. + - intro abs. destruct (s _ y _ abs); contradiction. + - intro abs. destruct (s _ y _ abs); contradiction. +Qed. + +Add Parametric Relation {R : ConstructiveReals} : (CRcarrier R) (CReq R) + reflexivity proved by (CReq_refl) + symmetry proved by (CReq_sym) + transitivity proved by (CReq_trans) + as CReq_rel. + +Instance CReq_relT : forall {R : ConstructiveReals}, + CRelationClasses.Equivalence (CReq R). +Proof. + split. exact CReq_refl. exact CReq_sym. exact CReq_trans. +Qed. + +Instance CRlt_morph + : forall {R : ConstructiveReals}, CMorphisms.Proper + (CMorphisms.respectful (CReq R) (CMorphisms.respectful (CReq R) CRelationClasses.iffT)) (CRlt R). +Proof. + intros R x y H x0 y0 H0. destruct H, H0. split. + - intro. destruct (CRltLinear R). destruct (s x y x0). assumption. + contradiction. destruct (s y y0 x0). + assumption. assumption. contradiction. + - intro. destruct (CRltLinear R). destruct (s y x y0). assumption. + contradiction. destruct (s x x0 y0). + assumption. assumption. contradiction. +Qed. + +Add Parametric Morphism {R : ConstructiveReals} : (CRle R) + with signature CReq R ==> CReq R ==> iff + as CRle_morph. +Proof. + intros. split. + - intros H1 H2. unfold CRle in H1. + rewrite <- H0 in H2. rewrite <- H in H2. contradiction. + - intros H1 H2. unfold CRle in H1. + rewrite H0 in H2. rewrite H in H2. contradiction. +Qed. + +Lemma CRplus_0_l : forall {R : ConstructiveReals} (x : CRcarrier R), + 0 + x == x. +Proof. + intros. destruct (CRisRing R). apply Radd_0_l. +Qed. + +Lemma CRplus_0_r : forall {R : ConstructiveReals} (x : CRcarrier R), + x + 0 == x. +Proof. + intros. destruct (CRisRing R). + transitivity (0 + x). + apply Radd_comm. apply Radd_0_l. +Qed. + +Lemma CRplus_opp_l : forall {R : ConstructiveReals} (x : CRcarrier R), + - x + x == 0. +Proof. + intros. destruct (CRisRing R). + transitivity (x + - x). + apply Radd_comm. apply Ropp_def. +Qed. + +Lemma CRplus_opp_r : forall {R : ConstructiveReals} (x : CRcarrier R), + x + - x == 0. +Proof. + intros. destruct (CRisRing R). apply Ropp_def. +Qed. + +Lemma CRopp_0 : forall {R : ConstructiveReals}, + CRopp R 0 == 0. +Proof. + intros. rewrite <- CRplus_0_r, CRplus_opp_l. + reflexivity. +Qed. + +Lemma CRplus_lt_compat_r : forall {R : ConstructiveReals} (r r1 r2 : CRcarrier R), + r1 < r2 -> r1 + r < r2 + r. +Proof. + intros. destruct (CRisRing R). + apply (CRlt_proper R (CRplus R r r1) (CRplus R r1 r) (Radd_comm _ _) + (CRplus R r2 r) (CRplus R r2 r)). + apply CReq_refl. + apply (CRlt_proper R _ _ (CReq_refl _) _ (CRplus R r r2)). + apply Radd_comm. apply CRplus_lt_compat_l. exact H. +Qed. + +Lemma CRplus_lt_reg_r : forall {R : ConstructiveReals} (r r1 r2 : CRcarrier R), + r1 + r < r2 + r -> r1 < r2. +Proof. + intros. destruct (CRisRing R). + apply (CRlt_proper R (CRplus R r r1) (CRplus R r1 r) (Radd_comm _ _) + (CRplus R r2 r) (CRplus R r2 r)) in H. + 2: apply CReq_refl. + apply (CRlt_proper R _ _ (CReq_refl _) _ (CRplus R r r2)) in H. + apply CRplus_lt_reg_l in H. exact H. + apply Radd_comm. +Qed. + +Lemma CRplus_le_compat_l : forall {R : ConstructiveReals} (r r1 r2 : CRcarrier R), + r1 <= r2 -> r + r1 <= r + r2. +Proof. + intros. intros abs. apply CRplus_lt_reg_l in abs. apply H. exact abs. +Qed. + +Lemma CRplus_le_compat_r : forall {R : ConstructiveReals} (r r1 r2 : CRcarrier R), + r1 <= r2 -> r1 + r <= r2 + r. +Proof. + intros. intros abs. apply CRplus_lt_reg_r in abs. apply H. exact abs. +Qed. + +Lemma CRplus_le_compat : forall {R : ConstructiveReals} (r1 r2 r3 r4 : CRcarrier R), + r1 <= r2 -> r3 <= r4 -> r1 + r3 <= r2 + r4. +Proof. + intros. apply (CRle_trans _ (CRplus R r2 r3)). + apply CRplus_le_compat_r, H. apply CRplus_le_compat_l, H0. +Qed. + +Lemma CRle_minus : forall {R : ConstructiveReals} (x y : CRcarrier R), + x <= y -> 0 <= y - x. +Proof. + intros. rewrite <- (CRplus_opp_r x). + apply CRplus_le_compat_r. exact H. +Qed. + +Lemma CRplus_le_reg_l : forall {R : ConstructiveReals} (r r1 r2 : CRcarrier R), + r + r1 <= r + r2 -> r1 <= r2. +Proof. + intros. intro abs. apply H. clear H. + apply CRplus_lt_compat_l. exact abs. +Qed. + +Lemma CRplus_le_reg_r : forall {R : ConstructiveReals} (r r1 r2 : CRcarrier R), + r1 + r <= r2 + r -> r1 <= r2. +Proof. + intros. intro abs. apply H. clear H. + apply CRplus_lt_compat_r. exact abs. +Qed. + +Lemma CRplus_lt_le_compat : + forall {R : ConstructiveReals} (r1 r2 r3 r4 : CRcarrier R), + r1 < r2 + -> r3 <= r4 + -> r1 + r3 < r2 + r4. +Proof. + intros. apply (CRlt_le_trans _ (CRplus R r2 r3)). + apply CRplus_lt_compat_r. exact H. intro abs. + apply CRplus_lt_reg_l in abs. contradiction. +Qed. + +Lemma CRplus_le_lt_compat : + forall {R : ConstructiveReals} (r1 r2 r3 r4 : CRcarrier R), + r1 <= r2 + -> r3 < r4 + -> r1 + r3 < r2 + r4. +Proof. + intros. apply (CRle_lt_trans _ (CRplus R r2 r3)). + apply CRplus_le_compat_r. exact H. + apply CRplus_lt_compat_l. exact H0. +Qed. + +Lemma CRplus_eq_reg_l : forall {R : ConstructiveReals} (r r1 r2 : CRcarrier R), + r + r1 == r + r2 -> r1 == r2. +Proof. + intros. + destruct (CRisRingExt R). clear Rmul_ext Ropp_ext. + pose proof (Radd_ext + (CRopp R r) (CRopp R r) (CReq_refl _) + _ _ H). + destruct (CRisRing R). + apply (CReq_trans r1) in H0. + apply (CReq_trans _ _ _ H0). + transitivity ((- r + r) + r2). + apply Radd_assoc. transitivity (0 + r2). + apply Radd_ext. apply CRplus_opp_l. apply CReq_refl. + apply Radd_0_l. apply CReq_sym. + transitivity (- r + r + r1). + apply Radd_assoc. + transitivity (0 + r1). + apply Radd_ext. apply CRplus_opp_l. apply CReq_refl. + apply Radd_0_l. +Qed. + +Lemma CRplus_eq_reg_r : forall {R : ConstructiveReals} (r r1 r2 : CRcarrier R), + r1 + r == r2 + r -> r1 == r2. +Proof. + intros. apply (CRplus_eq_reg_l r). + transitivity (r1 + r). apply (Radd_comm (CRisRing R)). + transitivity (r2 + r). + exact H. apply (Radd_comm (CRisRing R)). +Qed. + +Lemma CRplus_assoc : forall {R : ConstructiveReals} (r r1 r2 : CRcarrier R), + r + r1 + r2 == r + (r1 + r2). +Proof. + intros. symmetry. apply (Radd_assoc (CRisRing R)). +Qed. + +Lemma CRplus_comm : forall {R : ConstructiveReals} (r1 r2 : CRcarrier R), + r1 + r2 == r2 + r1. +Proof. + intros. apply (Radd_comm (CRisRing R)). +Qed. + +Add Parametric Morphism {R : ConstructiveReals} : (CRplus R) + with signature CReq R ==> CReq R ==> CReq R + as CRplus_morph. +Proof. + apply (CRisRingExt R). +Qed. + +Add Parametric Morphism {R : ConstructiveReals} : (CRopp R) + with signature CReq R ==> CReq R + as CRopp_morph. +Proof. + apply (CRisRingExt R). +Qed. + +Add Parametric Morphism {R : ConstructiveReals} : (CRmult R) + with signature CReq R ==> CReq R ==> CReq R + as CRmult_morph. +Proof. + apply (CRisRingExt R). +Qed. + +Instance CRplus_morph_T + : forall {R : ConstructiveReals}, CMorphisms.Proper + (CMorphisms.respectful (CReq R) (CMorphisms.respectful (CReq R) (CReq R))) (CRplus R). +Proof. + intros R x y H z t H1. apply CRplus_morph; assumption. +Qed. + +Instance CRmult_morph_T + : forall {R : ConstructiveReals}, CMorphisms.Proper + (CMorphisms.respectful (CReq R) (CMorphisms.respectful (CReq R) (CReq R))) (CRmult R). +Proof. + intros R x y H z t H1. apply CRmult_morph; assumption. +Qed. + +Instance CRopp_morph_T + : forall {R : ConstructiveReals}, CMorphisms.Proper + (CMorphisms.respectful (CReq R) (CReq R)) (CRopp R). +Proof. + apply CRisRingExt. +Qed. + +Add Parametric Morphism {R : ConstructiveReals} : (CRminus R) + with signature (CReq R) ==> (CReq R) ==> (CReq R) + as CRminus_morph. +Proof. + intros. unfold CRminus. rewrite H,H0. reflexivity. +Qed. + +Instance CRminus_morph_T + : forall {R : ConstructiveReals}, CMorphisms.Proper + (CMorphisms.respectful (CReq R) (CMorphisms.respectful (CReq R) (CReq R))) (CRminus R). +Proof. + intros R x y exy z t ezt. unfold CRminus. rewrite exy,ezt. reflexivity. +Qed. + +Lemma CRopp_involutive : forall {R : ConstructiveReals} (r : CRcarrier R), + - - r == r. +Proof. + intros. apply (CRplus_eq_reg_l (CRopp R r)). + transitivity (CRzero R). apply CRisRing. + apply CReq_sym. transitivity (r + - r). + apply CRisRing. apply CRisRing. +Qed. + +Lemma CRopp_gt_lt_contravar + : forall {R : ConstructiveReals} (r1 r2 : CRcarrier R), + r2 < r1 -> - r1 < - r2. +Proof. + intros. apply (CRplus_lt_reg_l R r1). + destruct (CRisRing R). + apply (CRle_lt_trans _ (CRzero R)). apply Ropp_def. + apply (CRplus_lt_compat_l R (CRopp R r2)) in H. + apply (CRle_lt_trans _ (CRplus R (CRopp R r2) r2)). + apply (CRle_trans _ (CRplus R r2 (CRopp R r2))). + destruct (Ropp_def r2). exact H0. + destruct (Radd_comm r2 (CRopp R r2)). exact H1. + apply (CRlt_le_trans _ _ _ H). + destruct (Radd_comm r1 (CRopp R r2)). exact H0. +Qed. + +Lemma CRopp_lt_cancel : forall {R : ConstructiveReals} (r1 r2 : CRcarrier R), + - r2 < - r1 -> r1 < r2. +Proof. + intros. apply (CRplus_lt_compat_r r1) in H. + rewrite (CRplus_opp_l r1) in H. + apply (CRplus_lt_compat_l R r2) in H. + rewrite CRplus_0_r, (Radd_assoc (CRisRing R)) in H. + rewrite CRplus_opp_r, (Radd_0_l (CRisRing R)) in H. + exact H. +Qed. + +Lemma CRopp_ge_le_contravar + : forall {R : ConstructiveReals} (r1 r2 : CRcarrier R), + r2 <= r1 -> - r1 <= - r2. +Proof. + intros. intros abs. apply CRopp_lt_cancel in abs. contradiction. +Qed. + +Lemma CRopp_plus_distr : forall {R : ConstructiveReals} (r1 r2 : CRcarrier R), + - (r1 + r2) == - r1 + - r2. +Proof. + intros. destruct (CRisRing R), (CRisRingExt R). + apply (CRplus_eq_reg_l (CRplus R r1 r2)). + transitivity (CRzero R). apply Ropp_def. + transitivity (r2 + r1 + (-r1 + -r2)). + transitivity (r2 + (r1 + (-r1 + -r2))). + transitivity (r2 + - r2). + apply CReq_sym. apply Ropp_def. apply Radd_ext. + apply CReq_refl. + transitivity (CRzero R + - r2). + apply CReq_sym, Radd_0_l. + transitivity (r1 + - r1 + - r2). + apply Radd_ext. 2: apply CReq_refl. apply CReq_sym, Ropp_def. + apply CReq_sym, Radd_assoc. apply Radd_assoc. + apply Radd_ext. 2: apply CReq_refl. apply Radd_comm. +Qed. + +Lemma CRmult_1_l : forall {R : ConstructiveReals} (r : CRcarrier R), + 1 * r == r. +Proof. + intros. destruct (CRisRing R). apply Rmul_1_l. +Qed. + +Lemma CRmult_1_r : forall {R : ConstructiveReals} (x : CRcarrier R), + x * 1 == x. +Proof. + intros. destruct (CRisRing R). transitivity (CRmult R 1 x). + apply Rmul_comm. apply Rmul_1_l. +Qed. + +Lemma CRmult_assoc : forall {R : ConstructiveReals} (r r1 r2 : CRcarrier R), + r * r1 * r2 == r * (r1 * r2). +Proof. + intros. symmetry. apply (Rmul_assoc (CRisRing R)). +Qed. + +Lemma CRmult_comm : forall {R : ConstructiveReals} (r s : CRcarrier R), + r * s == s * r. +Proof. + intros. rewrite (Rmul_comm (CRisRing R) r). reflexivity. +Qed. + +Lemma CRmult_plus_distr_l : forall {R : ConstructiveReals} (r1 r2 r3 : CRcarrier R), + r1 * (r2 + r3) == (r1 * r2) + (r1 * r3). +Proof. + intros. destruct (CRisRing R). + transitivity ((r2 + r3) * r1). + apply Rmul_comm. + transitivity ((r2 * r1) + (r3 * r1)). + apply Rdistr_l. + transitivity ((r1 * r2) + (r3 * r1)). + destruct (CRisRingExt R). apply Radd_ext. + apply Rmul_comm. apply CReq_refl. + destruct (CRisRingExt R). apply Radd_ext. + apply CReq_refl. apply Rmul_comm. +Qed. + +Lemma CRmult_plus_distr_r : forall {R : ConstructiveReals} (r1 r2 r3 : CRcarrier R), + (r2 + r3) * r1 == (r2 * r1) + (r3 * r1). +Proof. + intros. do 3 rewrite <- (CRmult_comm r1). + apply CRmult_plus_distr_l. +Qed. + +(* x == x+x -> x == 0 *) +Lemma CRzero_double : forall {R : ConstructiveReals} (x : CRcarrier R), + x == x + x -> x == 0. +Proof. + intros. + apply (CRplus_eq_reg_l x), CReq_sym. transitivity x. + apply CRplus_0_r. exact H. +Qed. + +Lemma CRmult_0_r : forall {R : ConstructiveReals} (x : CRcarrier R), + x * 0 == 0. +Proof. + intros. apply CRzero_double. + transitivity (x * (0 + 0)). + destruct (CRisRingExt R). apply Rmul_ext. apply CReq_refl. + apply CReq_sym, CRplus_0_r. + destruct (CRisRing R). apply CRmult_plus_distr_l. +Qed. + +Lemma CRmult_0_l : forall {R : ConstructiveReals} (r : CRcarrier R), + 0 * r == 0. +Proof. + intros. rewrite CRmult_comm. apply CRmult_0_r. +Qed. + +Lemma CRopp_mult_distr_r : forall {R : ConstructiveReals} (r1 r2 : CRcarrier R), + - (r1 * r2) == r1 * (- r2). +Proof. + intros. apply (CRplus_eq_reg_l (CRmult R r1 r2)). + destruct (CRisRing R). transitivity (CRzero R). apply Ropp_def. + transitivity (r1 * (r2 + - r2)). + 2: apply CRmult_plus_distr_l. + transitivity (r1 * 0). + apply CReq_sym, CRmult_0_r. + destruct (CRisRingExt R). apply Rmul_ext. apply CReq_refl. + apply CReq_sym, Ropp_def. +Qed. + +Lemma CRopp_mult_distr_l : forall {R : ConstructiveReals} (r1 r2 : CRcarrier R), + - (r1 * r2) == (- r1) * r2. +Proof. + intros. transitivity (r2 * - r1). + transitivity (- (r2 * r1)). + apply (Ropp_ext (CRisRingExt R)). + apply CReq_sym, (Rmul_comm (CRisRing R)). + apply CRopp_mult_distr_r. + apply CReq_sym, (Rmul_comm (CRisRing R)). +Qed. + +Lemma CRmult_lt_compat_r : forall {R : ConstructiveReals} (r r1 r2 : CRcarrier R), + 0 < r -> r1 < r2 -> r1 * r < r2 * r. +Proof. + intros. apply (CRplus_lt_reg_r (CRopp R (CRmult R r1 r))). + apply (CRle_lt_trans _ (CRzero R)). + apply (Ropp_def (CRisRing R)). + apply (CRlt_le_trans _ (CRplus R (CRmult R r2 r) (CRmult R (CRopp R r1) r))). + apply (CRlt_le_trans _ (CRmult R (CRplus R r2 (CRopp R r1)) r)). + apply CRmult_lt_0_compat. 2: exact H. + apply (CRplus_lt_reg_r r1). + apply (CRle_lt_trans _ r1). apply (Radd_0_l (CRisRing R)). + apply (CRlt_le_trans _ r2 _ H0). + apply (CRle_trans _ (CRplus R r2 (CRplus R (CRopp R r1) r1))). + apply (CRle_trans _ (CRplus R r2 (CRzero R))). + destruct (CRplus_0_r r2). exact H1. + apply CRplus_le_compat_l. destruct (CRplus_opp_l r1). exact H1. + destruct (Radd_assoc (CRisRing R) r2 (CRopp R r1) r1). exact H2. + destruct (CRisRing R). + destruct (Rdistr_l r2 (CRopp R r1) r). exact H2. + apply CRplus_le_compat_l. destruct (CRopp_mult_distr_l r1 r). + exact H1. +Qed. + +Lemma CRmult_lt_compat_l : forall {R : ConstructiveReals} (r r1 r2 : CRcarrier R), + 0 < r -> r1 < r2 -> r * r1 < r * r2. +Proof. + intros. do 2 rewrite (CRmult_comm r). + apply CRmult_lt_compat_r; assumption. +Qed. + +Lemma CRinv_r : forall {R : ConstructiveReals} (r:CRcarrier R) + (rnz : r ≶ (CRzero R)), + r * (/ r) rnz == 1. +Proof. + intros. transitivity ((/ r) rnz * r). + apply (CRisRing R). apply CRinv_l. +Qed. + +Lemma CRmult_lt_reg_r : forall {R : ConstructiveReals} (r r1 r2 : CRcarrier R), + 0 < r -> r1 * r < r2 * r -> r1 < r2. +Proof. + intros. apply (CRmult_lt_compat_r ((/ r) (inr H))) in H0. + 2: apply CRinv_0_lt_compat, H. + apply (CRle_lt_trans _ ((r1 * r) * ((/ r) (inr H)))). + - clear H0. apply (CRle_trans _ (CRmult R r1 (CRone R))). + destruct (CRmult_1_r r1). exact H0. + apply (CRle_trans _ (CRmult R r1 (CRmult R r ((/ r) (inr H))))). + destruct (Rmul_ext (CRisRingExt R) r1 r1 (CReq_refl r1) + (r * ((/ r) (inr H))) 1). + apply CRinv_r. exact H0. + destruct (Rmul_assoc (CRisRing R) r1 r ((/ r) (inr H))). exact H1. + - apply (CRlt_le_trans _ ((r2 * r) * ((/ r) (inr H)))). + exact H0. clear H0. + apply (CRle_trans _ (r2 * 1)). + 2: destruct (CRmult_1_r r2); exact H1. + apply (CRle_trans _ (r2 * (r * ((/ r) (inr H))))). + destruct (Rmul_assoc (CRisRing R) r2 r ((/ r) (inr H))). exact H0. + destruct (Rmul_ext (CRisRingExt R) r2 r2 (CReq_refl r2) + (r * ((/ r) (inr H))) (CRone R)). + apply CRinv_r. exact H1. +Qed. + +Lemma CRmult_lt_reg_l : forall {R : ConstructiveReals} (r r1 r2 : CRcarrier R), + 0 < r -> r * r1 < r * r2 -> r1 < r2. +Proof. + intros. + rewrite (Rmul_comm (CRisRing R) r r1) in H0. + rewrite (Rmul_comm (CRisRing R) r r2) in H0. + apply CRmult_lt_reg_r in H0. + exact H0. exact H. +Qed. + +Lemma CRmult_le_compat_l_half : forall {R : ConstructiveReals} (r r1 r2 : CRcarrier R), + 0 < r -> r1 <= r2 -> r * r1 <= r * r2. +Proof. + intros. intro abs. apply CRmult_lt_reg_l in abs. + contradiction. exact H. +Qed. + +Lemma CRmult_le_compat_r_half : forall {R : ConstructiveReals} (r r1 r2 : CRcarrier R), + 0 < r + -> r1 <= r2 + -> r1 * r <= r2 * r. +Proof. + intros. intro abs. apply CRmult_lt_reg_r in abs. + contradiction. exact H. +Qed. + +Lemma CRmult_eq_reg_r : forall {R : ConstructiveReals} (r r1 r2 : CRcarrier R), + 0 ≶ r + -> r1 * r == r2 * r + -> r1 == r2. +Proof. + intros. destruct H0,H. + - split. + + intro abs. apply H0. apply CRmult_lt_compat_r. + exact c. exact abs. + + intro abs. apply H1. apply CRmult_lt_compat_r. + exact c. exact abs. + - split. + + intro abs. apply H1. apply CRopp_lt_cancel. + apply (CRle_lt_trans _ (CRmult R r1 (CRopp R r))). + apply CRopp_mult_distr_r. + apply (CRlt_le_trans _ (CRmult R r2 (CRopp R r))). + 2: apply CRopp_mult_distr_r. + apply CRmult_lt_compat_r. 2: exact abs. + apply (CRplus_lt_reg_r r). apply (CRle_lt_trans _ r). + apply (Radd_0_l (CRisRing R)). + apply (CRlt_le_trans _ (CRzero R) _ c). + apply CRplus_opp_l. + + intro abs. apply H0. apply CRopp_lt_cancel. + apply (CRle_lt_trans _ (CRmult R r2 (CRopp R r))). + apply CRopp_mult_distr_r. + apply (CRlt_le_trans _ (CRmult R r1 (CRopp R r))). + 2: apply CRopp_mult_distr_r. + apply CRmult_lt_compat_r. 2: exact abs. + apply (CRplus_lt_reg_r r). apply (CRle_lt_trans _ r). + apply (Radd_0_l (CRisRing R)). + apply (CRlt_le_trans _ (CRzero R) _ c). + apply CRplus_opp_l. +Qed. + +Lemma CRinv_1 : forall {R : ConstructiveReals} (onz : CRapart R 1 0), + (/ 1) onz == 1. +Proof. + intros. rewrite <- (CRmult_1_r ((/ 1) onz)). + rewrite CRinv_l. reflexivity. +Qed. + +Lemma CRmult_eq_reg_l : forall {R : ConstructiveReals} (r r1 r2 : CRcarrier R), + r ≶ 0 + -> r * r1 == r * r2 + -> r1 == r2. +Proof. + intros. rewrite (Rmul_comm (CRisRing R)) in H0. + rewrite (Rmul_comm (CRisRing R) r) in H0. + apply CRmult_eq_reg_r in H0. exact H0. destruct H. + right. exact c. left. exact c. +Qed. + +Lemma CRinv_mult_distr : + forall {R : ConstructiveReals} (r1 r2 : CRcarrier R) + (r1nz : r1 ≶ 0) (r2nz : r2 ≶ 0) + (rmnz : (r1*r2) ≶ 0), + (/ (r1 * r2)) rmnz == (/ r1) r1nz * (/ r2) r2nz. +Proof. + intros. apply (CRmult_eq_reg_l r1). exact r1nz. + rewrite (Rmul_assoc (CRisRing R)). rewrite CRinv_r. rewrite CRmult_1_l. + apply (CRmult_eq_reg_l r2). exact r2nz. + rewrite CRinv_r. rewrite (Rmul_assoc (CRisRing R)). + rewrite (CRmult_comm r2 r1). rewrite CRinv_r. reflexivity. +Qed. + +Lemma CRinv_morph : forall {R : ConstructiveReals} (x y : CRcarrier R) + (rxnz : x ≶ 0) (rynz : y ≶ 0), + x == y + -> (/ x) rxnz == (/ y) rynz. +Proof. + intros. apply (CRmult_eq_reg_l x). exact rxnz. + rewrite CRinv_r, H, CRinv_r. reflexivity. +Qed. + +Lemma CRlt_minus : forall {R : ConstructiveReals} (x y : CRcarrier R), + x < y -> 0 < y - x. +Proof. + intros. rewrite <- (CRplus_opp_r x). + apply CRplus_lt_compat_r. exact H. +Qed. + +Lemma CR_of_Q_le : forall {R : ConstructiveReals} (r q : Q), + Qle r q + -> CR_of_Q R r <= CR_of_Q R q. +Proof. + intros. intro abs. apply lt_CR_of_Q in abs. + exact (Qlt_not_le _ _ abs H). +Qed. + +Add Parametric Morphism {R : ConstructiveReals} : (CR_of_Q R) + with signature Qeq ==> CReq R + as CR_of_Q_morph. +Proof. + split; apply CR_of_Q_le; rewrite H; apply Qle_refl. +Qed. + +Lemma eq_inject_Q : forall {R : ConstructiveReals} (q r : Q), + CR_of_Q R q == CR_of_Q R r -> Qeq q r. +Proof. + intros. destruct H. destruct (Q_dec q r). destruct s. + exfalso. apply (CR_of_Q_lt R q r) in q0. contradiction. + exfalso. apply (CR_of_Q_lt R r q) in q0. contradiction. exact q0. +Qed. + +Instance CR_of_Q_morph_T + : forall {R : ConstructiveReals}, CMorphisms.Proper + (CMorphisms.respectful Qeq (CReq R)) (CR_of_Q R). +Proof. + intros R x y H. apply CR_of_Q_morph; assumption. +Qed. + +Lemma CR_of_Q_zero : forall {R : ConstructiveReals}, + CR_of_Q R 0 == 0. +Proof. + intros. apply CRzero_double. + transitivity (CR_of_Q R (0+0)). apply CR_of_Q_morph. + reflexivity. apply CR_of_Q_plus. +Qed. + +Lemma CR_of_Q_opp : forall {R : ConstructiveReals} (q : Q), + CR_of_Q R (-q) == - CR_of_Q R q. +Proof. + intros. apply (CRplus_eq_reg_l (CR_of_Q R q)). + transitivity (CRzero R). + transitivity (CR_of_Q R (q-q)). + apply CReq_sym, CR_of_Q_plus. + transitivity (CR_of_Q R 0). + apply CR_of_Q_morph. ring. apply CR_of_Q_zero. + apply CReq_sym. apply (CRisRing R). +Qed. + +Lemma CR_of_Q_pos : forall {R : ConstructiveReals} (q:Q), + Qlt 0 q -> 0 < CR_of_Q R q. +Proof. + intros. apply (CRle_lt_trans _ (CR_of_Q R 0)). + apply CR_of_Q_zero. apply CR_of_Q_lt. exact H. +Qed. + +Lemma CR_of_Q_inv : forall {R : ConstructiveReals} (q : Q) (qPos : Qlt 0 q), + CR_of_Q R (/q) + == (/ CR_of_Q R q) (inr (CR_of_Q_pos q qPos)). +Proof. + intros. + apply (CRmult_eq_reg_l (CR_of_Q R q)). + right. apply CR_of_Q_pos, qPos. + rewrite CRinv_r, <- CR_of_Q_mult, <- CR_of_Q_one. + apply CR_of_Q_morph. field. intro abs. + rewrite abs in qPos. exact (Qlt_irrefl 0 qPos). +Qed. + +Lemma CRmult_le_0_compat : forall {R : ConstructiveReals} (a b : CRcarrier R), + 0 <= a -> 0 <= b -> 0 <= a * b. +Proof. + (* Limit of (a + 1/n)*b when n -> infty. *) + intros. intro abs. + assert (0 < -(a*b)) as epsPos. + { rewrite <- CRopp_0. apply CRopp_gt_lt_contravar. exact abs. } + destruct (CR_archimedean R (b * ((/ -(a*b)) (inr epsPos)))) + as [n maj]. + assert (0 < CR_of_Q R (Z.pos n #1)) as nPos. + { rewrite <- CR_of_Q_zero. apply CR_of_Q_lt. reflexivity. } + assert (b * (/ CR_of_Q R (Z.pos n #1)) (inr nPos) < -(a*b)). + { apply (CRmult_lt_reg_r (CR_of_Q R (Z.pos n #1))). apply nPos. + rewrite <- (Rmul_assoc (CRisRing R)), CRinv_l, CRmult_1_r. + apply (CRmult_lt_compat_r (-(a*b))) in maj. + rewrite CRmult_assoc, CRinv_l, CRmult_1_r in maj. + rewrite CRmult_comm. apply maj. apply epsPos. } + pose proof (CRmult_le_compat_l_half + (a + (/ CR_of_Q R (Z.pos n #1)) (inr nPos)) 0 b). + assert (0 + 0 < a + (/ CR_of_Q R (Z.pos n #1)) (inr nPos)). + { apply CRplus_le_lt_compat. apply H. apply CRinv_0_lt_compat. apply nPos. } + rewrite CRplus_0_l in H3. specialize (H2 H3 H0). + clear H3. rewrite CRmult_0_r in H2. + apply H2. clear H2. rewrite (Rdistr_l (CRisRing R)). + apply (CRplus_lt_compat_l R (a*b)) in H1. + rewrite CRplus_opp_r in H1. + rewrite (CRmult_comm ((/ CR_of_Q R (Z.pos n # 1)) (inr nPos))). + apply H1. +Qed. + +Lemma CRmult_le_compat_l : forall {R : ConstructiveReals} (r r1 r2:CRcarrier R), + 0 <= r -> r1 <= r2 -> r * r1 <= r * r2. +Proof. + intros. apply (CRplus_le_reg_r (-(r*r1))). + rewrite CRplus_opp_r, CRopp_mult_distr_r. + rewrite <- CRmult_plus_distr_l. + apply CRmult_le_0_compat. exact H. + apply (CRplus_le_reg_r r1). + rewrite CRplus_0_l, CRplus_assoc, CRplus_opp_l, CRplus_0_r. + exact H0. +Qed. + +Lemma CRmult_le_compat_r : forall {R : ConstructiveReals} (r r1 r2:CRcarrier R), + 0 <= r -> r1 <= r2 -> r1 * r <= r2 * r. +Proof. + intros. do 2 rewrite <- (CRmult_comm r). + apply CRmult_le_compat_l; assumption. +Qed. + +Lemma CRmult_pos_pos + : forall {R : ConstructiveReals} (x y : CRcarrier R), + 0 < x * y -> 0 <= x + -> 0 <= y -> 0 < x. +Proof. + intros. destruct (CRltLinear R). clear p. + specialize (s 0 x 1 (CRzero_lt_one R)) as [H2|H2]. + exact H2. apply CRlt_asym in H2. + apply (CRmult_le_compat_r y) in H2. + 2: exact H1. rewrite CRmult_1_l in H2. + apply (CRlt_le_trans _ _ _ H) in H2. + rewrite <- (CRmult_0_l y) in H. + apply CRmult_lt_reg_r in H. exact H. exact H2. +Qed. + +(* In particular x * y == 1 implies that 0 # x, 0 # y and + that x and y are inverses of each other. *) +Lemma CRmult_pos_appart_zero + : forall {R : ConstructiveReals} (x y : CRcarrier R), + 0 < x * y -> 0 ≶ x. +Proof. + intros. + (* Narrow cases to x < 1. *) + destruct (CRltLinear R). clear p. + pose proof (s 0 x 1 (CRzero_lt_one R)) as [H0|H0]. + left. exact H0. + (* In this case, linear order 0 y (x*y) decides. *) + destruct (s 0 y (x*y) H). + - left. rewrite <- (CRmult_0_l y) in H. apply CRmult_lt_reg_r in H. + exact H. exact c. + - right. apply CRopp_lt_cancel. rewrite CRopp_0. + apply (CRmult_pos_pos (-x) (-y)). + + rewrite <- CRopp_mult_distr_l, CRopp_mult_distr_r, CRopp_involutive. exact H. + + rewrite <- CRopp_0. apply CRopp_ge_le_contravar. + intro abs. rewrite <- (CRmult_0_r x) in H. + apply CRmult_lt_reg_l in H. rewrite <- (CRmult_1_l y) in c. + rewrite <- CRmult_assoc in c. apply CRmult_lt_reg_r in c. + rewrite CRmult_1_r in c. exact (CRlt_asym _ _ H0 c). + exact H. exact abs. + + intro abs. apply (CRmult_lt_compat_r y) in H0. + rewrite CRmult_1_l in H0. exact (CRlt_asym _ _ H0 c). + apply CRopp_lt_cancel. rewrite CRopp_0. exact abs. +Qed. + +Lemma CRmult_le_reg_l : + forall {R : ConstructiveReals} (x y z : CRcarrier R), + 0 < x -> x * y <= x * z -> y <= z. +Proof. + intros. intro abs. + apply (CRmult_lt_compat_l x) in abs. contradiction. + exact H. +Qed. + +Lemma CRmult_le_reg_r : + forall {R : ConstructiveReals} (x y z : CRcarrier R), + 0 < x -> y * x <= z * x -> y <= z. +Proof. + intros. intro abs. + apply (CRmult_lt_compat_r x) in abs. contradiction. exact H. +Qed. + +Definition CRup_nat {R : ConstructiveReals} (x : CRcarrier R) + : { n : nat & x < CR_of_Q R (Z.of_nat n #1) }. +Proof. + destruct (CR_archimedean R x). exists (Pos.to_nat x0). + rewrite positive_nat_Z. exact c. +Qed. + +Definition CRfloor {R : ConstructiveReals} (a : CRcarrier R) + : { p : Z & prod (CR_of_Q R (p#1) < a) + (a < CR_of_Q R (p#1) + CR_of_Q R 2) }. +Proof. + destruct (CR_Q_dense R (a - CR_of_Q R (1#2)) a) as [q qmaj]. + - apply (CRlt_le_trans _ (a-0)). apply CRplus_lt_compat_l. + apply CRopp_gt_lt_contravar. rewrite <- CR_of_Q_zero. + apply CR_of_Q_lt. reflexivity. + unfold CRminus. rewrite CRopp_0, CRplus_0_r. apply CRle_refl. + - exists (Qfloor q). destruct qmaj. split. + apply (CRle_lt_trans _ (CR_of_Q R q)). 2: exact c0. + apply CR_of_Q_le. apply Qfloor_le. + apply (CRlt_le_trans _ (CR_of_Q R q + CR_of_Q R (1#2))). + apply (CRplus_lt_compat_r (CR_of_Q R (1 # 2))) in c. + unfold CRminus in c. rewrite CRplus_assoc, CRplus_opp_l, CRplus_0_r in c. exact c. + rewrite (CR_of_Q_plus R 1 1), <- CRplus_assoc, <- (CR_of_Q_plus R _ 1). + apply CRplus_le_compat. apply CR_of_Q_le. + rewrite Qinv_plus_distr. apply Qlt_le_weak, Qlt_floor. + apply CR_of_Q_le. discriminate. +Qed. + +Lemma CRplus_appart_reg_l : forall {R : ConstructiveReals} (r r1 r2 : CRcarrier R), + (r + r1) ≶ (r + r2) -> r1 ≶ r2. +Proof. + intros. destruct H. + left. apply (CRplus_lt_reg_l R r), c. + right. apply (CRplus_lt_reg_l R r), c. +Qed. + +Lemma CRplus_appart_reg_r : forall {R : ConstructiveReals} (r r1 r2 : CRcarrier R), + (r1 + r) ≶ (r2 + r) -> r1 ≶ r2. +Proof. + intros. destruct H. + left. apply (CRplus_lt_reg_r r), c. + right. apply (CRplus_lt_reg_r r), c. +Qed. + +Lemma CRmult_appart_reg_l + : forall {R : ConstructiveReals} (r r1 r2 : CRcarrier R), + 0 < r -> (r * r1) ≶ (r * r2) -> r1 ≶ r2. +Proof. + intros. destruct H0. + left. exact (CRmult_lt_reg_l r _ _ H c). + right. exact (CRmult_lt_reg_l r _ _ H c). +Qed. + +Lemma CRmult_appart_reg_r + : forall {R : ConstructiveReals} (r r1 r2 : CRcarrier R), + 0 < r -> (r1 * r) ≶ (r2 * r) -> r1 ≶ r2. +Proof. + intros. destruct H0. + left. exact (CRmult_lt_reg_r r _ _ H c). + right. exact (CRmult_lt_reg_r r _ _ H c). +Qed. + +Instance CRapart_morph + : forall {R : ConstructiveReals}, CMorphisms.Proper + (CMorphisms.respectful (CReq R) (CMorphisms.respectful (CReq R) CRelationClasses.iffT)) (CRapart R). +Proof. + intros R x y H x0 y0 H0. destruct H, H0. split. + - intro. destruct H3. + left. apply (CRle_lt_trans _ x _ H). + apply (CRlt_le_trans _ x0 _ c), H2. + right. apply (CRle_lt_trans _ x0 _ H0). + apply (CRlt_le_trans _ x _ c), H1. + - intro. destruct H3. + left. apply (CRle_lt_trans _ y _ H1). + apply (CRlt_le_trans _ y0 _ c), H0. + right. apply (CRle_lt_trans _ y0 _ H2). + apply (CRlt_le_trans _ y _ c), H. +Qed. diff --git a/theories/Reals/Abstract/ConstructiveRealsMorphisms.v b/theories/Reals/Abstract/ConstructiveRealsMorphisms.v new file mode 100644 index 0000000000..bc44668e2f --- /dev/null +++ b/theories/Reals/Abstract/ConstructiveRealsMorphisms.v @@ -0,0 +1,1177 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) +(************************************************************************) + +(** Morphisms used to transport results from any instance of + ConstructiveReals to any other. + Between any two constructive reals structures R1 and R2, + all morphisms R1 -> R2 are extensionally equal. We will + further show that they exist, and so are isomorphisms. + The difference between two morphisms R1 -> R2 is therefore + the speed of computation. + + The canonical isomorphisms we provide here are often very slow, + when a new implementation of constructive reals is added, + it should define its own ad hoc isomorphisms for better speed. + + Apart from the speed, those unique isomorphisms also serve as + sanity checks of the interface ConstructiveReals : + it captures a concept with a strong notion of uniqueness. *) + +Require Import QArith. +Require Import Qabs. +Require Import ConstructiveReals. +Require Import ConstructiveLimits. +Require Import ConstructiveAbs. +Require Import ConstructiveSum. + +Local Open Scope ConstructiveReals. + +Record ConstructiveRealsMorphism {R1 R2 : ConstructiveReals} : Set := + { + CRmorph : CRcarrier R1 -> CRcarrier R2; + CRmorph_rat : forall q : Q, + CRmorph (CR_of_Q R1 q) == CR_of_Q R2 q; + CRmorph_increasing : forall x y : CRcarrier R1, + CRlt R1 x y -> CRlt R2 (CRmorph x) (CRmorph y); + }. + + +Lemma CRmorph_increasing_inv + : forall {R1 R2 : ConstructiveReals} + (f : ConstructiveRealsMorphism) + (x y : CRcarrier R1), + CRlt R2 (CRmorph f x) (CRmorph f y) + -> CRlt R1 x y. +Proof. + intros. destruct (CR_Q_dense R2 _ _ H) as [q [H0 H1]]. + destruct (CR_Q_dense R2 _ _ H0) as [r [H2 H3]]. + apply lt_CR_of_Q, (CR_of_Q_lt R1) in H3. + destruct (CRltLinear R1). + destruct (s _ x _ H3). + - exfalso. apply (CRmorph_increasing f) in c. + destruct (CRmorph_rat f r) as [H4 _]. + apply (CRle_lt_trans _ _ _ H4) in c. clear H4. + exact (CRlt_asym _ _ c H2). + - clear H2 H3 r. apply (CRlt_trans _ _ _ c). clear c. + destruct (CR_Q_dense R2 _ _ H1) as [t [H2 H3]]. + apply lt_CR_of_Q, (CR_of_Q_lt R1) in H2. + destruct (s _ y _ H2). exact c. + exfalso. apply (CRmorph_increasing f) in c. + destruct (CRmorph_rat f t) as [_ H4]. + apply (CRlt_le_trans _ _ _ c) in H4. clear c. + exact (CRlt_asym _ _ H4 H3). +Qed. + +Lemma CRmorph_unique : forall {R1 R2 : ConstructiveReals} + (f g : @ConstructiveRealsMorphism R1 R2) + (x : CRcarrier R1), + CRmorph f x == CRmorph g x. +Proof. + split. + - intro abs. destruct (CR_Q_dense R2 _ _ abs) as [q [H H0]]. + destruct (CRmorph_rat f q) as [H1 _]. + apply (CRlt_le_trans _ _ _ H) in H1. clear H. + apply CRmorph_increasing_inv in H1. + destruct (CRmorph_rat g q) as [_ H2]. + apply (CRle_lt_trans _ _ _ H2) in H0. clear H2. + apply CRmorph_increasing_inv in H0. + exact (CRlt_asym _ _ H0 H1). + - intro abs. destruct (CR_Q_dense R2 _ _ abs) as [q [H H0]]. + destruct (CRmorph_rat f q) as [_ H1]. + apply (CRle_lt_trans _ _ _ H1) in H0. clear H1. + apply CRmorph_increasing_inv in H0. + destruct (CRmorph_rat g q) as [H2 _]. + apply (CRlt_le_trans _ _ _ H) in H2. clear H. + apply CRmorph_increasing_inv in H2. + exact (CRlt_asym _ _ H0 H2). +Qed. + + +(* The identity is the only endomorphism of constructive reals. + For any ConstructiveReals R1, R2 and any morphisms + f : R1 -> R2 and g : R2 -> R1, + f and g are isomorphisms and are inverses of each other. *) +Lemma Endomorph_id + : forall {R : ConstructiveReals} (f : @ConstructiveRealsMorphism R R) + (x : CRcarrier R), + CRmorph f x == x. +Proof. + split. + - intro abs. destruct (CR_Q_dense R _ _ abs) as [q [H0 H1]]. + destruct (CRmorph_rat f q) as [H _]. + apply (CRlt_le_trans _ _ _ H0) in H. clear H0. + apply CRmorph_increasing_inv in H. + exact (CRlt_asym _ _ H1 H). + - intro abs. destruct (CR_Q_dense R _ _ abs) as [q [H0 H1]]. + destruct (CRmorph_rat f q) as [_ H]. + apply (CRle_lt_trans _ _ _ H) in H1. clear H. + apply CRmorph_increasing_inv in H1. + exact (CRlt_asym _ _ H1 H0). +Qed. + +Lemma CRmorph_proper + : forall {R1 R2 : ConstructiveReals} + (f : @ConstructiveRealsMorphism R1 R2) + (x y : CRcarrier R1), + x == y -> CRmorph f x == CRmorph f y. +Proof. + split. + - intro abs. apply CRmorph_increasing_inv in abs. + destruct H. contradiction. + - intro abs. apply CRmorph_increasing_inv in abs. + destruct H. contradiction. +Qed. + +Definition CRmorph_compose {R1 R2 R3 : ConstructiveReals} + (f : @ConstructiveRealsMorphism R1 R2) + (g : @ConstructiveRealsMorphism R2 R3) + : @ConstructiveRealsMorphism R1 R3. +Proof. + apply (Build_ConstructiveRealsMorphism + R1 R3 (fun x:CRcarrier R1 => CRmorph g (CRmorph f x))). + - intro q. apply (CReq_trans _ (CRmorph g (CR_of_Q R2 q))). + apply CRmorph_proper. apply CRmorph_rat. apply CRmorph_rat. + - intros. apply CRmorph_increasing. apply CRmorph_increasing. exact H. +Defined. + +Lemma CRmorph_le : forall {R1 R2 : ConstructiveReals} + (f : @ConstructiveRealsMorphism R1 R2) + (x y : CRcarrier R1), + x <= y -> CRmorph f x <= CRmorph f y. +Proof. + intros. intro abs. apply CRmorph_increasing_inv in abs. contradiction. +Qed. + +Lemma CRmorph_le_inv : forall {R1 R2 : ConstructiveReals} + (f : @ConstructiveRealsMorphism R1 R2) + (x y : CRcarrier R1), + CRmorph f x <= CRmorph f y -> x <= y. +Proof. + intros. intro abs. apply (CRmorph_increasing f) in abs. contradiction. +Qed. + +Lemma CRmorph_zero : forall {R1 R2 : ConstructiveReals} + (f : @ConstructiveRealsMorphism R1 R2), + CRmorph f 0 == 0. +Proof. + intros. apply (CReq_trans _ (CRmorph f (CR_of_Q R1 0))). + apply CRmorph_proper. apply CReq_sym, CR_of_Q_zero. + apply (CReq_trans _ (CR_of_Q R2 0)). + apply CRmorph_rat. apply CR_of_Q_zero. +Qed. + +Lemma CRmorph_one : forall {R1 R2 : ConstructiveReals} + (f : @ConstructiveRealsMorphism R1 R2), + CRmorph f 1 == 1. +Proof. + intros. apply (CReq_trans _ (CRmorph f (CR_of_Q R1 1))). + apply CRmorph_proper. apply CReq_sym, CR_of_Q_one. + apply (CReq_trans _ (CR_of_Q R2 1)). + apply CRmorph_rat. apply CR_of_Q_one. +Qed. + +Lemma CRmorph_opp : forall {R1 R2 : ConstructiveReals} + (f : @ConstructiveRealsMorphism R1 R2) + (x : CRcarrier R1), + CRmorph f (- x) == - CRmorph f x. +Proof. + split. + - intro abs. + destruct (CR_Q_dense R2 _ _ abs) as [q [H H0]]. clear abs. + destruct (CRmorph_rat f q) as [H1 _]. + apply (CRlt_le_trans _ _ _ H) in H1. clear H. + apply CRmorph_increasing_inv in H1. + apply CRopp_gt_lt_contravar in H0. + destruct (@CR_of_Q_opp R2 q) as [H2 _]. + apply (CRlt_le_trans _ _ _ H0) in H2. clear H0. + pose proof (CRopp_involutive (CRmorph f x)) as [H _]. + apply (CRle_lt_trans _ _ _ H) in H2. clear H. + destruct (CRmorph_rat f (-q)) as [H _]. + apply (CRlt_le_trans _ _ _ H2) in H. clear H2. + apply CRmorph_increasing_inv in H. + destruct (@CR_of_Q_opp R1 q) as [_ H2]. + apply (CRlt_le_trans _ _ _ H) in H2. clear H. + apply CRopp_gt_lt_contravar in H2. + pose proof (CRopp_involutive (CR_of_Q R1 q)) as [H _]. + apply (CRle_lt_trans _ _ _ H) in H2. clear H. + exact (CRlt_asym _ _ H1 H2). + - intro abs. + destruct (CR_Q_dense R2 _ _ abs) as [q [H H0]]. clear abs. + destruct (CRmorph_rat f q) as [_ H1]. + apply (CRle_lt_trans _ _ _ H1) in H0. clear H1. + apply CRmorph_increasing_inv in H0. + apply CRopp_gt_lt_contravar in H. + pose proof (CRopp_involutive (CRmorph f x)) as [_ H1]. + apply (CRlt_le_trans _ _ _ H) in H1. clear H. + destruct (@CR_of_Q_opp R2 q) as [_ H2]. + apply (CRle_lt_trans _ _ _ H2) in H1. clear H2. + destruct (CRmorph_rat f (-q)) as [_ H]. + apply (CRle_lt_trans _ _ _ H) in H1. clear H. + apply CRmorph_increasing_inv in H1. + destruct (@CR_of_Q_opp R1 q) as [H2 _]. + apply (CRle_lt_trans _ _ _ H2) in H1. clear H2. + apply CRopp_gt_lt_contravar in H1. + pose proof (CRopp_involutive (CR_of_Q R1 q)) as [_ H]. + apply (CRlt_le_trans _ _ _ H1) in H. clear H1. + exact (CRlt_asym _ _ H0 H). +Qed. + +Lemma CRplus_pos_rat_lt : forall {R : ConstructiveReals} (x : CRcarrier R) (q : Q), + Qlt 0 q -> CRlt R x (CRplus R x (CR_of_Q R q)). +Proof. + intros. + apply (CRle_lt_trans _ (CRplus R x (CRzero R))). apply CRplus_0_r. + apply CRplus_lt_compat_l. + apply (CRle_lt_trans _ (CR_of_Q R 0)). apply CR_of_Q_zero. + apply CR_of_Q_lt. exact H. +Defined. + +Lemma CRplus_neg_rat_lt : forall {R : ConstructiveReals} (x : CRcarrier R) (q : Q), + Qlt q 0 -> CRlt R (CRplus R x (CR_of_Q R q)) x. +Proof. + intros. + apply (CRlt_le_trans _ (CRplus R x (CRzero R))). 2: apply CRplus_0_r. + apply CRplus_lt_compat_l. + apply (CRlt_le_trans _ (CR_of_Q R 0)). + apply CR_of_Q_lt. exact H. apply CR_of_Q_zero. +Qed. + +Lemma CRmorph_plus_rat : forall {R1 R2 : ConstructiveReals} + (f : @ConstructiveRealsMorphism R1 R2) + (x : CRcarrier R1) (q : Q), + CRmorph f (CRplus R1 x (CR_of_Q R1 q)) + == CRplus R2 (CRmorph f x) (CR_of_Q R2 q). +Proof. + split. + - intro abs. + destruct (CR_Q_dense R2 _ _ abs) as [r [H H0]]. clear abs. + destruct (CRmorph_rat f r) as [H1 _]. + apply (CRlt_le_trans _ _ _ H) in H1. clear H. + apply CRmorph_increasing_inv in H1. + apply (CRlt_asym _ _ H1). clear H1. + apply (CRplus_lt_reg_r (CRopp R1 (CR_of_Q R1 q))). + apply (CRlt_le_trans _ x). + apply (CRle_lt_trans _ (CR_of_Q R1 (r-q))). + apply (CRle_trans _ (CRplus R1 (CR_of_Q R1 r) (CR_of_Q R1 (-q)))). + apply CRplus_le_compat_l. destruct (@CR_of_Q_opp R1 q). exact H. + destruct (CR_of_Q_plus R1 r (-q)). exact H. + apply (CRmorph_increasing_inv f). + apply (CRle_lt_trans _ (CR_of_Q R2 (r - q))). + apply CRmorph_rat. + apply (CRplus_lt_reg_r (CR_of_Q R2 q)). + apply (CRle_lt_trans _ (CR_of_Q R2 r)). 2: exact H0. + intro H. + destruct (CR_of_Q_plus R2 (r-q) q) as [H1 _]. + apply (CRlt_le_trans _ _ _ H) in H1. clear H. + apply lt_CR_of_Q in H1. ring_simplify in H1. + exact (Qlt_not_le _ _ H1 (Qle_refl _)). + destruct (CRisRing R1). + apply (CRle_trans + _ (CRplus R1 x (CRplus R1 (CR_of_Q R1 q) (CRopp R1 (CR_of_Q R1 q))))). + apply (CRle_trans _ (CRplus R1 x (CRzero R1))). + destruct (CRplus_0_r x). exact H. + apply CRplus_le_compat_l. destruct (Ropp_def (CR_of_Q R1 q)). exact H. + destruct (Radd_assoc x (CR_of_Q R1 q) (CRopp R1 (CR_of_Q R1 q))). + exact H1. + - intro abs. + destruct (CR_Q_dense R2 _ _ abs) as [r [H H0]]. clear abs. + destruct (CRmorph_rat f r) as [_ H1]. + apply (CRle_lt_trans _ _ _ H1) in H0. clear H1. + apply CRmorph_increasing_inv in H0. + apply (CRlt_asym _ _ H0). clear H0. + apply (CRplus_lt_reg_r (CRopp R1 (CR_of_Q R1 q))). + apply (CRle_lt_trans _ x). + destruct (CRisRing R1). + apply (CRle_trans + _ (CRplus R1 x (CRplus R1 (CR_of_Q R1 q) (CRopp R1 (CR_of_Q R1 q))))). + destruct (Radd_assoc x (CR_of_Q R1 q) (CRopp R1 (CR_of_Q R1 q))). + exact H0. + apply (CRle_trans _ (CRplus R1 x (CRzero R1))). + apply CRplus_le_compat_l. destruct (Ropp_def (CR_of_Q R1 q)). exact H1. + destruct (CRplus_0_r x). exact H1. + apply (CRlt_le_trans _ (CR_of_Q R1 (r-q))). + apply (CRmorph_increasing_inv f). + apply (CRlt_le_trans _ (CR_of_Q R2 (r - q))). + apply (CRplus_lt_reg_r (CR_of_Q R2 q)). + apply (CRlt_le_trans _ _ _ H). + 2: apply CRmorph_rat. + apply (CRle_trans _ (CR_of_Q R2 (r-q+q))). + intro abs. apply lt_CR_of_Q in abs. ring_simplify in abs. + exact (Qlt_not_le _ _ abs (Qle_refl _)). + destruct (CR_of_Q_plus R2 (r-q) q). exact H1. + apply (CRle_trans _ (CRplus R1 (CR_of_Q R1 r) (CR_of_Q R1 (-q)))). + destruct (CR_of_Q_plus R1 r (-q)). exact H1. + apply CRplus_le_compat_l. destruct (@CR_of_Q_opp R1 q). exact H1. +Qed. + +Lemma CRmorph_plus : forall {R1 R2 : ConstructiveReals} + (f : @ConstructiveRealsMorphism R1 R2) + (x y : CRcarrier R1), + CRmorph f (CRplus R1 x y) + == CRplus R2 (CRmorph f x) (CRmorph f y). +Proof. + intros R1 R2 f. + assert (forall (x y : CRcarrier R1), + CRplus R2 (CRmorph f x) (CRmorph f y) + <= CRmorph f (CRplus R1 x y)). + { intros x y abs. destruct (CR_Q_dense R2 _ _ abs) as [r [H H0]]. clear abs. + destruct (CRmorph_rat f r) as [H1 _]. + apply (CRlt_le_trans _ _ _ H) in H1. clear H. + apply CRmorph_increasing_inv in H1. + apply (CRlt_asym _ _ H1). clear H1. + destruct (CR_Q_dense R2 _ _ H0) as [q [H2 H3]]. + apply lt_CR_of_Q in H2. + assert (Qlt (r-q) 0) as epsNeg. + { apply (Qplus_lt_r _ _ q). ring_simplify. exact H2. } + destruct (CR_Q_dense R1 _ _ (CRplus_neg_rat_lt x (r-q) epsNeg)) + as [s [H4 H5]]. + apply (CRlt_trans _ (CRplus R1 (CR_of_Q R1 s) y)). + 2: apply CRplus_lt_compat_r, H5. + apply (CRmorph_increasing_inv f). + apply (CRlt_le_trans _ (CRplus R2 (CR_of_Q R2 s) (CRmorph f y))). + apply (CRmorph_increasing f) in H4. + destruct (CRmorph_plus_rat f x (r-q)) as [H _]. + apply (CRle_lt_trans _ _ _ H) in H4. clear H. + destruct (CRmorph_rat f s) as [_ H1]. + apply (CRlt_le_trans _ _ _ H4) in H1. clear H4. + apply (CRlt_trans + _ (CRplus R2 (CRplus R2 (CRmorph f x) (CR_of_Q R2 (r - q))) + (CRmorph f y))). + 2: apply CRplus_lt_compat_r, H1. + apply (CRlt_le_trans + _ (CRplus R2 (CRplus R2 (CR_of_Q R2 (r - q)) (CRmorph f x)) + (CRmorph f y))). + apply (CRlt_le_trans + _ (CRplus R2 (CR_of_Q R2 (r - q)) + (CRplus R2 (CRmorph f x) (CRmorph f y)))). + apply (CRle_lt_trans _ (CRplus R2 (CR_of_Q R2 (r - q)) (CR_of_Q R2 q))). + 2: apply CRplus_lt_compat_l, H3. + intro abs. + destruct (CR_of_Q_plus R2 (r-q) q) as [_ H4]. + apply (CRle_lt_trans _ _ _ H4) in abs. clear H4. + destruct (CRmorph_rat f r) as [_ H4]. + apply (CRlt_le_trans _ _ _ abs) in H4. clear abs. + apply lt_CR_of_Q in H4. ring_simplify in H4. + exact (Qlt_not_le _ _ H4 (Qle_refl _)). + destruct (CRisRing R2); apply Radd_assoc. + apply CRplus_le_compat_r. destruct (CRisRing R2). + destruct (Radd_comm (CRmorph f x) (CR_of_Q R2 (r - q))). + exact H. + intro abs. + destruct (CRmorph_plus_rat f y s) as [H _]. apply H. clear H. + apply (CRlt_le_trans _ (CRplus R2 (CR_of_Q R2 s) (CRmorph f y))). + apply (CRle_lt_trans _ (CRmorph f (CRplus R1 (CR_of_Q R1 s) y))). + apply CRmorph_proper. destruct (CRisRing R1); apply Radd_comm. + exact abs. destruct (CRisRing R2); apply Radd_comm. } + split. + - apply H. + - specialize (H (CRplus R1 x y) (CRopp R1 y)). + intro abs. apply H. clear H. + apply (CRle_lt_trans _ (CRmorph f x)). + apply CRmorph_proper. destruct (CRisRing R1). + apply (CReq_trans _ (CRplus R1 x (CRplus R1 y (CRopp R1 y)))). + apply CReq_sym, Radd_assoc. + apply (CReq_trans _ (CRplus R1 x (CRzero R1))). 2: apply CRplus_0_r. + destruct (CRisRingExt R1). apply Radd_ext. + apply CReq_refl. apply Ropp_def. + apply (CRplus_lt_reg_r (CRmorph f y)). + apply (CRlt_le_trans _ _ _ abs). clear abs. + apply (CRle_trans _ (CRplus R2 (CRmorph f (CRplus R1 x y)) (CRzero R2))). + destruct (CRplus_0_r (CRmorph f (CRplus R1 x y))). exact H. + apply (CRle_trans _ (CRplus R2 (CRmorph f (CRplus R1 x y)) + (CRplus R2 (CRmorph f (CRopp R1 y)) (CRmorph f y)))). + apply CRplus_le_compat_l. + apply (CRle_trans + _ (CRplus R2 (CRopp R2 (CRmorph f y)) (CRmorph f y))). + destruct (CRplus_opp_l (CRmorph f y)). exact H. + apply CRplus_le_compat_r. destruct (CRmorph_opp f y). exact H. + destruct (CRisRing R2). + destruct (Radd_assoc (CRmorph f (CRplus R1 x y)) + (CRmorph f (CRopp R1 y)) (CRmorph f y)). + exact H0. +Qed. + +Lemma CRmorph_mult_pos : forall {R1 R2 : ConstructiveReals} + (f : @ConstructiveRealsMorphism R1 R2) + (x : CRcarrier R1) (n : nat), + CRmorph f (CRmult R1 x (CR_of_Q R1 (Z.of_nat n # 1))) + == CRmult R2 (CRmorph f x) (CR_of_Q R2 (Z.of_nat n # 1)). +Proof. + induction n. + - simpl. destruct (CRisRingExt R1). + apply (CReq_trans _ (CRzero R2)). + + apply (CReq_trans _ (CRmorph f (CRzero R1))). + 2: apply CRmorph_zero. apply CRmorph_proper. + apply (CReq_trans _ (CRmult R1 x (CRzero R1))). + 2: apply CRmult_0_r. apply Rmul_ext. apply CReq_refl. apply CR_of_Q_zero. + + apply (CReq_trans _ (CRmult R2 (CRmorph f x) (CRzero R2))). + apply CReq_sym, CRmult_0_r. destruct (CRisRingExt R2). + apply Rmul_ext0. apply CReq_refl. apply CReq_sym, CR_of_Q_zero. + - destruct (CRisRingExt R1), (CRisRingExt R2). + apply (CReq_trans + _ (CRmorph f (CRplus R1 x (CRmult R1 x (CR_of_Q R1 (Z.of_nat n # 1)))))). + apply CRmorph_proper. + apply (CReq_trans + _ (CRmult R1 x (CRplus R1 (CRone R1) (CR_of_Q R1 (Z.of_nat n # 1))))). + apply Rmul_ext. apply CReq_refl. + apply (CReq_trans _ (CR_of_Q R1 (1 + (Z.of_nat n # 1)))). + apply CR_of_Q_morph. rewrite Nat2Z.inj_succ. unfold Z.succ. + rewrite Z.add_comm. rewrite Qinv_plus_distr. reflexivity. + apply (CReq_trans _ (CRplus R1 (CR_of_Q R1 1) (CR_of_Q R1 (Z.of_nat n # 1)))). + apply CR_of_Q_plus. apply Radd_ext. apply CR_of_Q_one. apply CReq_refl. + apply (CReq_trans _ (CRplus R1 (CRmult R1 x (CRone R1)) + (CRmult R1 x (CR_of_Q R1 (Z.of_nat n # 1))))). + apply CRmult_plus_distr_l. apply Radd_ext. apply CRmult_1_r. apply CReq_refl. + apply (CReq_trans + _ (CRplus R2 (CRmorph f x) + (CRmorph f (CRmult R1 x (CR_of_Q R1 (Z.of_nat n # 1)))))). + apply CRmorph_plus. + apply (CReq_trans + _ (CRplus R2 (CRmorph f x) + (CRmult R2 (CRmorph f x) (CR_of_Q R2 (Z.of_nat n # 1))))). + apply Radd_ext0. apply CReq_refl. exact IHn. + apply (CReq_trans + _ (CRmult R2 (CRmorph f x) (CRplus R2 (CRone R2) (CR_of_Q R2 (Z.of_nat n # 1))))). + apply (CReq_trans + _ (CRplus R2 (CRmult R2 (CRmorph f x) (CRone R2)) + (CRmult R2 (CRmorph f x) (CR_of_Q R2 (Z.of_nat n # 1))))). + apply Radd_ext0. 2: apply CReq_refl. apply CReq_sym, CRmult_1_r. + apply CReq_sym, CRmult_plus_distr_l. + apply Rmul_ext0. apply CReq_refl. + apply (CReq_trans _ (CR_of_Q R2 (1 + (Z.of_nat n # 1)))). + apply (CReq_trans _ (CRplus R2 (CR_of_Q R2 1) (CR_of_Q R2 (Z.of_nat n # 1)))). + apply Radd_ext0. apply CReq_sym, CR_of_Q_one. apply CReq_refl. + apply CReq_sym, CR_of_Q_plus. + apply CR_of_Q_morph. rewrite Nat2Z.inj_succ. unfold Z.succ. + rewrite Z.add_comm. rewrite Qinv_plus_distr. reflexivity. +Qed. + +Lemma NatOfZ : forall n : Z, { p : nat | n = Z.of_nat p \/ n = Z.opp (Z.of_nat p) }. +Proof. + intros [|p|n]. + - exists O. left. reflexivity. + - exists (Pos.to_nat p). left. rewrite positive_nat_Z. reflexivity. + - exists (Pos.to_nat n). right. rewrite positive_nat_Z. reflexivity. +Qed. + +Lemma CRmorph_mult_int : forall {R1 R2 : ConstructiveReals} + (f : @ConstructiveRealsMorphism R1 R2) + (x : CRcarrier R1) (n : Z), + CRmorph f (CRmult R1 x (CR_of_Q R1 (n # 1))) + == CRmult R2 (CRmorph f x) (CR_of_Q R2 (n # 1)). +Proof. + intros. destruct (NatOfZ n) as [p [pos|neg]]. + - subst n. apply CRmorph_mult_pos. + - subst n. + apply (CReq_trans + _ (CRopp R2 (CRmorph f (CRmult R1 x (CR_of_Q R1 (Z.of_nat p # 1)))))). + + apply (CReq_trans + _ (CRmorph f (CRopp R1 (CRmult R1 x (CR_of_Q R1 (Z.of_nat p # 1)))))). + 2: apply CRmorph_opp. apply CRmorph_proper. + apply (CReq_trans _ (CRmult R1 x (CR_of_Q R1 (- (Z.of_nat p # 1))))). + destruct (CRisRingExt R1). apply Rmul_ext. apply CReq_refl. + apply CR_of_Q_morph. reflexivity. + apply (CReq_trans _ (CRmult R1 x (CRopp R1 (CR_of_Q R1 (Z.of_nat p # 1))))). + destruct (CRisRingExt R1). apply Rmul_ext. apply CReq_refl. + apply CR_of_Q_opp. apply CReq_sym, CRopp_mult_distr_r. + + apply (CReq_trans + _ (CRopp R2 (CRmult R2 (CRmorph f x) (CR_of_Q R2 (Z.of_nat p # 1))))). + destruct (CRisRingExt R2). apply Ropp_ext. apply CRmorph_mult_pos. + apply (CReq_trans + _ (CRmult R2 (CRmorph f x) (CRopp R2 (CR_of_Q R2 (Z.of_nat p # 1))))). + apply CRopp_mult_distr_r. destruct (CRisRingExt R2). + apply Rmul_ext. apply CReq_refl. + apply (CReq_trans _ (CR_of_Q R2 (- (Z.of_nat p # 1)))). + apply CReq_sym, CR_of_Q_opp. apply CR_of_Q_morph. reflexivity. +Qed. + +Lemma CRmorph_mult_inv : forall {R1 R2 : ConstructiveReals} + (f : @ConstructiveRealsMorphism R1 R2) + (x : CRcarrier R1) (p : positive), + CRmorph f (CRmult R1 x (CR_of_Q R1 (1 # p))) + == CRmult R2 (CRmorph f x) (CR_of_Q R2 (1 # p)). +Proof. + intros. apply (CRmult_eq_reg_r (CR_of_Q R2 (Z.pos p # 1))). + left. apply (CRle_lt_trans _ (CR_of_Q R2 0)). + apply CR_of_Q_zero. apply CR_of_Q_lt. reflexivity. + apply (CReq_trans _ (CRmorph f x)). + - apply (CReq_trans + _ (CRmorph f (CRmult R1 (CRmult R1 x (CR_of_Q R1 (1 # p))) + (CR_of_Q R1 (Z.pos p # 1))))). + apply CReq_sym, CRmorph_mult_int. apply CRmorph_proper. + apply (CReq_trans + _ (CRmult R1 x (CRmult R1 (CR_of_Q R1 (1 # p)) + (CR_of_Q R1 (Z.pos p # 1))))). + destruct (CRisRing R1). apply CReq_sym, Rmul_assoc. + apply (CReq_trans _ (CRmult R1 x (CRone R1))). + apply (Rmul_ext (CRisRingExt R1)). apply CReq_refl. + apply (CReq_trans _ (CR_of_Q R1 ((1#p) * (Z.pos p # 1)))). + apply CReq_sym, CR_of_Q_mult. + apply (CReq_trans _ (CR_of_Q R1 1)). + apply CR_of_Q_morph. reflexivity. apply CR_of_Q_one. + apply CRmult_1_r. + - apply (CReq_trans + _ (CRmult R2 (CRmorph f x) + (CRmult R2 (CR_of_Q R2 (1 # p)) (CR_of_Q R2 (Z.pos p # 1))))). + 2: apply (Rmul_assoc (CRisRing R2)). + apply (CReq_trans _ (CRmult R2 (CRmorph f x) (CRone R2))). + apply CReq_sym, CRmult_1_r. + apply (Rmul_ext (CRisRingExt R2)). apply CReq_refl. + apply (CReq_trans _ (CR_of_Q R2 1)). + apply CReq_sym, CR_of_Q_one. + apply (CReq_trans _ (CR_of_Q R2 ((1#p)*(Z.pos p # 1)))). + apply CR_of_Q_morph. reflexivity. apply CR_of_Q_mult. +Qed. + +Lemma CRmorph_mult_rat : forall {R1 R2 : ConstructiveReals} + (f : @ConstructiveRealsMorphism R1 R2) + (x : CRcarrier R1) (q : Q), + CRmorph f (CRmult R1 x (CR_of_Q R1 q)) + == CRmult R2 (CRmorph f x) (CR_of_Q R2 q). +Proof. + intros. destruct q as [a b]. + apply (CReq_trans + _ (CRmult R2 (CRmorph f (CRmult R1 x (CR_of_Q R1 (a # 1)))) + (CR_of_Q R2 (1 # b)))). + - apply (CReq_trans + _ (CRmorph f (CRmult R1 (CRmult R1 x (CR_of_Q R1 (a # 1))) + (CR_of_Q R1 (1 # b))))). + 2: apply CRmorph_mult_inv. apply CRmorph_proper. + apply (CReq_trans + _ (CRmult R1 x (CRmult R1 (CR_of_Q R1 (a # 1)) + (CR_of_Q R1 (1 # b))))). + apply (Rmul_ext (CRisRingExt R1)). apply CReq_refl. + apply (CReq_trans _ (CR_of_Q R1 ((a#1)*(1#b)))). + apply CR_of_Q_morph. unfold Qeq; simpl. rewrite Z.mul_1_r. reflexivity. + apply CR_of_Q_mult. + apply (Rmul_assoc (CRisRing R1)). + - apply (CReq_trans + _ (CRmult R2 (CRmult R2 (CRmorph f x) (CR_of_Q R2 (a # 1))) + (CR_of_Q R2 (1 # b)))). + apply (Rmul_ext (CRisRingExt R2)). apply CRmorph_mult_int. + apply CReq_refl. + apply (CReq_trans + _ (CRmult R2 (CRmorph f x) + (CRmult R2 (CR_of_Q R2 (a # 1)) (CR_of_Q R2 (1 # b))))). + apply CReq_sym, (Rmul_assoc (CRisRing R2)). + apply (Rmul_ext (CRisRingExt R2)). apply CReq_refl. + apply (CReq_trans _ (CR_of_Q R2 ((a#1)*(1#b)))). + apply CReq_sym, CR_of_Q_mult. + apply CR_of_Q_morph. unfold Qeq; simpl. rewrite Z.mul_1_r. reflexivity. +Qed. + +Lemma CRmorph_mult_pos_pos_le : forall {R1 R2 : ConstructiveReals} + (f : @ConstructiveRealsMorphism R1 R2) + (x y : CRcarrier R1), + CRlt R1 (CRzero R1) y + -> CRmult R2 (CRmorph f x) (CRmorph f y) + <= CRmorph f (CRmult R1 x y). +Proof. + intros. intro abs. destruct (CR_Q_dense R2 _ _ abs) as [q [H1 H2]]. + destruct (CRmorph_rat f q) as [H3 _]. + apply (CRlt_le_trans _ _ _ H1) in H3. clear H1. + apply CRmorph_increasing_inv in H3. + apply (CRlt_asym _ _ H3). clear H3. + destruct (CR_Q_dense R2 _ _ H2) as [r [H1 H3]]. + apply lt_CR_of_Q in H1. + destruct (CR_archimedean R1 y) as [A Amaj]. + assert (/ ((r - q) * (1 # A)) * (q - r) == - (Z.pos A # 1))%Q as diveq. + { rewrite Qinv_mult_distr. setoid_replace (q-r)%Q with (-1*(r-q))%Q. + field_simplify. reflexivity. 2: field. + split. intro H4. inversion H4. intro H4. + apply Qlt_minus_iff in H1. rewrite H4 in H1. inversion H1. } + destruct (CR_Q_dense R1 (CRplus R1 x (CR_of_Q R1 ((q-r) * (1#A)))) x) + as [s [H4 H5]]. + - apply (CRlt_le_trans _ (CRplus R1 x (CRzero R1))). + 2: apply CRplus_0_r. apply CRplus_lt_compat_l. + apply (CRplus_lt_reg_l R1 (CR_of_Q R1 ((r-q) * (1#A)))). + apply (CRle_lt_trans _ (CRzero R1)). + apply (CRle_trans _ (CR_of_Q R1 ((r-q)*(1#A) + (q-r)*(1#A)))). + destruct (CR_of_Q_plus R1 ((r-q)*(1#A)) ((q-r)*(1#A))). + exact H0. apply (CRle_trans _ (CR_of_Q R1 0)). + 2: destruct (@CR_of_Q_zero R1); exact H4. + intro H4. apply lt_CR_of_Q in H4. ring_simplify in H4. + inversion H4. + apply (CRlt_le_trans _ (CR_of_Q R1 ((r - q) * (1 # A)))). + 2: apply CRplus_0_r. + apply (CRle_lt_trans _ (CR_of_Q R1 0)). + apply CR_of_Q_zero. apply CR_of_Q_lt. + rewrite <- (Qmult_0_r (r-q)). apply Qmult_lt_l. + apply Qlt_minus_iff in H1. exact H1. reflexivity. + - apply (CRmorph_increasing f) in H4. + destruct (CRmorph_plus f x (CR_of_Q R1 ((q-r) * (1#A)))) as [H6 _]. + apply (CRle_lt_trans _ _ _ H6) in H4. clear H6. + destruct (CRmorph_rat f s) as [_ H6]. + apply (CRlt_le_trans _ _ _ H4) in H6. clear H4. + apply (CRmult_lt_compat_r (CRmorph f y)) in H6. + destruct (Rdistr_l (CRisRing R2) (CRmorph f x) + (CRmorph f (CR_of_Q R1 ((q-r) * (1#A)))) + (CRmorph f y)) as [H4 _]. + apply (CRle_lt_trans _ _ _ H4) in H6. clear H4. + apply (CRle_lt_trans _ (CRmult R1 (CR_of_Q R1 s) y)). + 2: apply CRmult_lt_compat_r. 2: exact H. 2: exact H5. + apply (CRmorph_le_inv f). + apply (CRle_trans _ (CR_of_Q R2 q)). + destruct (CRmorph_rat f q). exact H4. + apply (CRle_trans _ (CRmult R2 (CR_of_Q R2 s) (CRmorph f y))). + apply (CRle_trans _ (CRplus R2 (CRmult R2 (CRmorph f x) (CRmorph f y)) + (CR_of_Q R2 (q-r)))). + apply (CRle_trans _ (CRplus R2 (CR_of_Q R2 r) (CR_of_Q R2 (q - r)))). + + apply (CRle_trans _ (CR_of_Q R2 (r + (q-r)))). + intro H4. apply lt_CR_of_Q in H4. ring_simplify in H4. + exact (Qlt_not_le q q H4 (Qle_refl q)). + destruct (CR_of_Q_plus R2 r (q-r)). exact H4. + + apply CRplus_le_compat_r. intro H4. + apply (CRlt_asym _ _ H3). exact H4. + + intro H4. apply (CRlt_asym _ _ H4). clear H4. + apply (CRlt_trans_flip _ _ _ H6). clear H6. + apply CRplus_lt_compat_l. + apply (CRlt_le_trans + _ (CRmult R2 (CR_of_Q R2 ((q - r) * (1 # A))) (CRmorph f y))). + apply (CRmult_lt_reg_l (CR_of_Q R2 (/((r-q)*(1#A))))). + apply (CRle_lt_trans _ (CR_of_Q R2 0)). apply CR_of_Q_zero. + apply CR_of_Q_lt, Qinv_lt_0_compat. + rewrite <- (Qmult_0_r (r-q)). apply Qmult_lt_l. + apply Qlt_minus_iff in H1. exact H1. reflexivity. + apply (CRle_lt_trans _ (CRopp R2 (CR_of_Q R2 (Z.pos A # 1)))). + apply (CRle_trans _ (CR_of_Q R2 (-(Z.pos A # 1)))). + apply (CRle_trans _ (CR_of_Q R2 ((/ ((r - q) * (1 # A))) * (q - r)))). + destruct (CR_of_Q_mult R2 (/ ((r - q) * (1 # A))) (q - r)). + exact H0. destruct (CR_of_Q_morph R2 (/ ((r - q) * (1 # A)) * (q - r)) + (-(Z.pos A # 1))). + exact diveq. intro H7. apply lt_CR_of_Q in H7. + rewrite diveq in H7. exact (Qlt_not_le _ _ H7 (Qle_refl _)). + destruct (@CR_of_Q_opp R2 (Z.pos A # 1)). exact H4. + apply (CRlt_le_trans _ (CRopp R2 (CRmorph f y))). + apply CRopp_gt_lt_contravar. + apply (CRlt_le_trans _ (CRmorph f (CR_of_Q R1 (Z.pos A # 1)))). + apply CRmorph_increasing. exact Amaj. + destruct (CRmorph_rat f (Z.pos A # 1)). exact H4. + apply (CRle_trans _ (CRmult R2 (CRopp R2 (CRone R2)) (CRmorph f y))). + apply (CRle_trans _ (CRopp R2 (CRmult R2 (CRone R2) (CRmorph f y)))). + destruct (Ropp_ext (CRisRingExt R2) (CRmorph f y) + (CRmult R2 (CRone R2) (CRmorph f y))). + apply CReq_sym, (Rmul_1_l (CRisRing R2)). exact H4. + destruct (CRopp_mult_distr_l (CRone R2) (CRmorph f y)). exact H4. + apply (CRle_trans _ (CRmult R2 (CRmult R2 (CR_of_Q R2 (/ ((r - q) * (1 # A)))) + (CR_of_Q R2 ((q - r) * (1 # A)))) + (CRmorph f y))). + apply CRmult_le_compat_r_half. + apply (CRle_lt_trans _ (CRmorph f (CRzero R1))). + apply CRmorph_zero. apply CRmorph_increasing. exact H. + apply (CRle_trans _ (CR_of_Q R2 ((/ ((r - q) * (1 # A))) + * ((q - r) * (1 # A))))). + apply (CRle_trans _ (CR_of_Q R2 (-1))). + apply (CRle_trans _ (CRopp R2 (CR_of_Q R2 1))). + destruct (Ropp_ext (CRisRingExt R2) (CRone R2) (CR_of_Q R2 1)). + apply CReq_sym, CR_of_Q_one. exact H4. + destruct (@CR_of_Q_opp R2 1). exact H0. + destruct (CR_of_Q_morph R2 (-1) (/ ((r - q) * (1 # A)) * ((q - r) * (1 # A)))). + field. split. + intro H4. inversion H4. intro H4. apply Qlt_minus_iff in H1. + rewrite H4 in H1. inversion H1. exact H4. + destruct (CR_of_Q_mult R2 (/ ((r - q) * (1 # A))) ((q - r) * (1 # A))). + exact H4. + destruct (Rmul_assoc (CRisRing R2) (CR_of_Q R2 (/ ((r - q) * (1 # A)))) + (CR_of_Q R2 ((q - r) * (1 # A))) + (CRmorph f y)). + exact H0. + apply CRmult_le_compat_r_half. + apply (CRle_lt_trans _ (CRmorph f (CRzero R1))). + apply CRmorph_zero. apply CRmorph_increasing. exact H. + destruct (CRmorph_rat f ((q - r) * (1 # A))). exact H0. + + apply (CRle_trans _ (CRmorph f (CRmult R1 y (CR_of_Q R1 s)))). + apply (CRle_trans _ (CRmult R2 (CRmorph f y) (CR_of_Q R2 s))). + destruct (Rmul_comm (CRisRing R2) (CRmorph f y) (CR_of_Q R2 s)). + exact H0. + destruct (CRmorph_mult_rat f y s). exact H0. + destruct (CRmorph_proper f (CRmult R1 y (CR_of_Q R1 s)) + (CRmult R1 (CR_of_Q R1 s) y)). + apply (Rmul_comm (CRisRing R1)). exact H4. + + apply (CRle_lt_trans _ (CRmorph f (CRzero R1))). + apply CRmorph_zero. apply CRmorph_increasing. exact H. +Qed. + +Lemma CRmorph_mult_pos_pos : forall {R1 R2 : ConstructiveReals} + (f : @ConstructiveRealsMorphism R1 R2) + (x y : CRcarrier R1), + CRlt R1 (CRzero R1) y + -> CRmorph f (CRmult R1 x y) + == CRmult R2 (CRmorph f x) (CRmorph f y). +Proof. + split. apply CRmorph_mult_pos_pos_le. exact H. + intro abs. destruct (CR_Q_dense R2 _ _ abs) as [q [H1 H2]]. + destruct (CRmorph_rat f q) as [_ H3]. + apply (CRle_lt_trans _ _ _ H3) in H2. clear H3. + apply CRmorph_increasing_inv in H2. + apply (CRlt_asym _ _ H2). clear H2. + destruct (CR_Q_dense R2 _ _ H1) as [r [H2 H3]]. + apply lt_CR_of_Q in H3. + destruct (CR_archimedean R1 y) as [A Amaj]. + destruct (CR_Q_dense R1 x (CRplus R1 x (CR_of_Q R1 ((q-r) * (1#A))))) + as [s [H4 H5]]. + - apply (CRle_lt_trans _ (CRplus R1 x (CRzero R1))). + apply CRplus_0_r. apply CRplus_lt_compat_l. + apply (CRle_lt_trans _ (CR_of_Q R1 0)). + apply CR_of_Q_zero. apply CR_of_Q_lt. + rewrite <- (Qmult_0_r (q-r)). apply Qmult_lt_l. + apply Qlt_minus_iff in H3. exact H3. reflexivity. + - apply (CRmorph_increasing f) in H5. + destruct (CRmorph_plus f x (CR_of_Q R1 ((q-r) * (1#A)))) as [_ H6]. + apply (CRlt_le_trans _ _ _ H5) in H6. clear H5. + destruct (CRmorph_rat f s) as [H5 _ ]. + apply (CRle_lt_trans _ _ _ H5) in H6. clear H5. + apply (CRmult_lt_compat_r (CRmorph f y)) in H6. + apply (CRlt_le_trans _ (CRmult R1 (CR_of_Q R1 s) y)). + apply CRmult_lt_compat_r. exact H. exact H4. clear H4. + apply (CRmorph_le_inv f). + apply (CRle_trans _ (CR_of_Q R2 q)). + 2: destruct (CRmorph_rat f q); exact H0. + apply (CRle_trans _ (CRmult R2 (CR_of_Q R2 s) (CRmorph f y))). + + apply (CRle_trans _ (CRmorph f (CRmult R1 y (CR_of_Q R1 s)))). + destruct (CRmorph_proper f (CRmult R1 (CR_of_Q R1 s) y) + (CRmult R1 y (CR_of_Q R1 s))). + apply (Rmul_comm (CRisRing R1)). exact H4. + apply (CRle_trans _ (CRmult R2 (CRmorph f y) (CR_of_Q R2 s))). + exact (proj2 (CRmorph_mult_rat f y s)). + destruct (Rmul_comm (CRisRing R2) (CR_of_Q R2 s) (CRmorph f y)). + exact H0. + + intro H5. apply (CRlt_asym _ _ H5). clear H5. + apply (CRlt_trans _ _ _ H6). clear H6. + apply (CRle_lt_trans + _ (CRplus R2 + (CRmult R2 (CRmorph f x) (CRmorph f y)) + (CRmult R2 (CRmorph f (CR_of_Q R1 ((q - r) * (1 # A)))) + (CRmorph f y)))). + apply (Rdistr_l (CRisRing R2)). + apply (CRle_lt_trans + _ (CRplus R2 (CR_of_Q R2 r) + (CRmult R2 (CRmorph f (CR_of_Q R1 ((q - r) * (1 # A)))) + (CRmorph f y)))). + apply CRplus_le_compat_r. intro H5. apply (CRlt_asym _ _ H5 H2). + clear H2. + apply (CRle_lt_trans + _ (CRplus R2 (CR_of_Q R2 r) + (CRmult R2 (CR_of_Q R2 ((q - r) * (1 # A))) + (CRmorph f y)))). + apply CRplus_le_compat_l, CRmult_le_compat_r_half. + apply (CRle_lt_trans _ (CRmorph f (CRzero R1))). + apply CRmorph_zero. apply CRmorph_increasing. exact H. + destruct (CRmorph_rat f ((q - r) * (1 # A))). exact H2. + apply (CRlt_le_trans _ (CRplus R2 (CR_of_Q R2 r) + (CR_of_Q R2 ((q - r))))). + apply CRplus_lt_compat_l. + * apply (CRmult_lt_reg_l (CR_of_Q R2 (/((q - r) * (1 # A))))). + apply (CRle_lt_trans _ (CR_of_Q R2 0)). apply CR_of_Q_zero. + apply CR_of_Q_lt, Qinv_lt_0_compat. + rewrite <- (Qmult_0_r (q-r)). apply Qmult_lt_l. + apply Qlt_minus_iff in H3. exact H3. reflexivity. + apply (CRle_lt_trans _ (CRmorph f y)). + apply (CRle_trans _ (CRmult R2 (CRmult R2 (CR_of_Q R2 (/ ((q - r) * (1 # A)))) + (CR_of_Q R2 ((q - r) * (1 # A)))) + (CRmorph f y))). + exact (proj2 (Rmul_assoc (CRisRing R2) (CR_of_Q R2 (/ ((q - r) * (1 # A)))) + (CR_of_Q R2 ((q - r) * (1 # A))) + (CRmorph f y))). + apply (CRle_trans _ (CRmult R2 (CRone R2) (CRmorph f y))). + apply CRmult_le_compat_r_half. + apply (CRle_lt_trans _ (CRmorph f (CRzero R1))). + apply CRmorph_zero. apply CRmorph_increasing. exact H. + apply (CRle_trans + _ (CR_of_Q R2 ((/ ((q - r) * (1 # A))) * ((q - r) * (1 # A))))). + exact (proj1 (CR_of_Q_mult R2 (/ ((q - r) * (1 # A))) ((q - r) * (1 # A)))). + apply (CRle_trans _ (CR_of_Q R2 1)). + destruct (CR_of_Q_morph R2 (/ ((q - r) * (1 # A)) * ((q - r) * (1 # A))) 1). + field_simplify. reflexivity. split. + intro H5. inversion H5. intro H5. apply Qlt_minus_iff in H3. + rewrite H5 in H3. inversion H3. exact H2. + destruct (CR_of_Q_one R2). exact H2. + destruct (Rmul_1_l (CRisRing R2) (CRmorph f y)). + intro H5. contradiction. + apply (CRlt_le_trans _ (CR_of_Q R2 (Z.pos A # 1))). + apply (CRlt_le_trans _ (CRmorph f (CR_of_Q R1 (Z.pos A # 1)))). + apply CRmorph_increasing. exact Amaj. + exact (proj2 (CRmorph_rat f (Z.pos A # 1))). + apply (CRle_trans _ (CR_of_Q R2 ((/ ((q - r) * (1 # A))) * (q - r)))). + 2: exact (proj2 (CR_of_Q_mult R2 (/ ((q - r) * (1 # A))) (q - r))). + destruct (CR_of_Q_morph R2 (Z.pos A # 1) (/ ((q - r) * (1 # A)) * (q - r))). + field_simplify. reflexivity. split. + intro H5. inversion H5. intro H5. apply Qlt_minus_iff in H3. + rewrite H5 in H3. inversion H3. exact H2. + * apply (CRle_trans _ (CR_of_Q R2 (r + (q-r)))). + exact (proj1 (CR_of_Q_plus R2 r (q-r))). + destruct (CR_of_Q_morph R2 (r + (q-r)) q). ring. exact H2. + + apply (CRle_lt_trans _ (CRmorph f (CRzero R1))). + apply CRmorph_zero. apply CRmorph_increasing. exact H. +Qed. + +Lemma CRmorph_mult : forall {R1 R2 : ConstructiveReals} + (f : @ConstructiveRealsMorphism R1 R2) + (x y : CRcarrier R1), + CRmorph f (CRmult R1 x y) + == CRmult R2 (CRmorph f x) (CRmorph f y). +Proof. + intros. + destruct (CR_archimedean R1 (CRopp R1 y)) as [p pmaj]. + apply (CRplus_eq_reg_r (CRmult R2 (CRmorph f x) + (CR_of_Q R2 (Z.pos p # 1)))). + apply (CReq_trans _ (CRmorph f (CRmult R1 x (CRplus R1 y (CR_of_Q R1 (Z.pos p # 1)))))). + - apply (CReq_trans _ (CRplus R2 (CRmorph f (CRmult R1 x y)) + (CRmorph f (CRmult R1 x (CR_of_Q R1 (Z.pos p # 1)))))). + apply (Radd_ext (CRisRingExt R2)). apply CReq_refl. + apply CReq_sym, CRmorph_mult_int. + apply (CReq_trans _ (CRmorph f (CRplus R1 (CRmult R1 x y) + (CRmult R1 x (CR_of_Q R1 (Z.pos p # 1)))))). + apply CReq_sym, CRmorph_plus. apply CRmorph_proper. + apply CReq_sym, CRmult_plus_distr_l. + - apply (CReq_trans _ (CRmult R2 (CRmorph f x) + (CRmorph f (CRplus R1 y (CR_of_Q R1 (Z.pos p # 1)))))). + apply CRmorph_mult_pos_pos. + apply (CRplus_lt_compat_l R1 y) in pmaj. + apply (CRle_lt_trans _ (CRplus R1 y (CRopp R1 y))). + 2: exact pmaj. apply (CRisRing R1). + apply (CReq_trans _ (CRmult R2 (CRmorph f x) + (CRplus R2 (CRmorph f y) (CR_of_Q R2 (Z.pos p # 1))))). + apply (Rmul_ext (CRisRingExt R2)). apply CReq_refl. + apply (CReq_trans _ (CRplus R2 (CRmorph f y) + (CRmorph f (CR_of_Q R1 (Z.pos p # 1))))). + apply CRmorph_plus. + apply (Radd_ext (CRisRingExt R2)). apply CReq_refl. + apply CRmorph_rat. + apply CRmult_plus_distr_l. +Qed. + +Lemma CRmorph_appart : forall {R1 R2 : ConstructiveReals} + (f : @ConstructiveRealsMorphism R1 R2) + (x y : CRcarrier R1) + (app : x ≶ y), + CRmorph f x ≶ CRmorph f y. +Proof. + intros. destruct app. + - left. apply CRmorph_increasing. exact c. + - right. apply CRmorph_increasing. exact c. +Defined. + +Lemma CRmorph_appart_zero : forall {R1 R2 : ConstructiveReals} + (f : @ConstructiveRealsMorphism R1 R2) + (x : CRcarrier R1) + (app : x ≶ 0), + CRmorph f x ≶ 0. +Proof. + intros. destruct app. + - left. apply (CRlt_le_trans _ (CRmorph f (CRzero R1))). + apply CRmorph_increasing. exact c. + exact (proj2 (CRmorph_zero f)). + - right. apply (CRle_lt_trans _ (CRmorph f (CRzero R1))). + exact (proj1 (CRmorph_zero f)). + apply CRmorph_increasing. exact c. +Defined. + +Lemma CRmorph_inv : forall {R1 R2 : ConstructiveReals} + (f : @ConstructiveRealsMorphism R1 R2) + (x : CRcarrier R1) + (xnz : x ≶ 0) + (fxnz : CRmorph f x ≶ 0), + CRmorph f ((/ x) xnz) + == (/ CRmorph f x) fxnz. +Proof. + intros. apply (CRmult_eq_reg_r (CRmorph f x)). + destruct fxnz. right. exact c. left. exact c. + apply (CReq_trans _ (CRone R2)). + 2: apply CReq_sym, CRinv_l. + apply (CReq_trans _ (CRmorph f (CRmult R1 ((/ x) xnz) x))). + apply CReq_sym, CRmorph_mult. + apply (CReq_trans _ (CRmorph f 1)). + apply CRmorph_proper. apply CRinv_l. + apply CRmorph_one. +Qed. + +Lemma CRmorph_sum : forall {R1 R2 : ConstructiveReals} + (f : @ConstructiveRealsMorphism R1 R2) + (un : nat -> CRcarrier R1) (n : nat), + CRmorph f (CRsum un n) == + CRsum (fun n0 : nat => CRmorph f (un n0)) n. +Proof. + induction n. + - reflexivity. + - simpl. rewrite CRmorph_plus, IHn. reflexivity. +Qed. + +Lemma CRmorph_INR : forall {R1 R2 : ConstructiveReals} + (f : @ConstructiveRealsMorphism R1 R2) + (n : nat), + CRmorph f (INR n) == INR n. +Proof. + induction n. + - apply CRmorph_rat. + - simpl. unfold INR. + rewrite (CRmorph_proper f _ (1 + CR_of_Q R1 (Z.of_nat n # 1))). + rewrite CRmorph_plus. unfold INR in IHn. + rewrite IHn. rewrite CRmorph_one, <- CR_of_Q_one, <- CR_of_Q_plus. + apply CR_of_Q_morph. rewrite Qinv_plus_distr. + unfold Qeq, Qnum, Qden. do 2 rewrite Z.mul_1_r. + rewrite Nat2Z.inj_succ. rewrite <- Z.add_1_l. reflexivity. + rewrite <- CR_of_Q_one, <- CR_of_Q_plus. + apply CR_of_Q_morph. rewrite Qinv_plus_distr. + unfold Qeq, Qnum, Qden. do 2 rewrite Z.mul_1_r. + rewrite Nat2Z.inj_succ. rewrite <- Z.add_1_l. reflexivity. +Qed. + +Lemma CRmorph_rat_cv + : forall {R1 R2 : ConstructiveReals} + (qn : nat -> Q), + CR_cauchy R1 (fun n => CR_of_Q R1 (qn n)) + -> CR_cauchy R2 (fun n => CR_of_Q R2 (qn n)). +Proof. + intros. intro p. destruct (H p) as [n nmaj]. + exists n. intros. specialize (nmaj i j H0 H1). + unfold CRminus. rewrite <- CR_of_Q_opp, <- CR_of_Q_plus, CR_of_Q_abs. + unfold CRminus in nmaj. rewrite <- CR_of_Q_opp, <- CR_of_Q_plus, CR_of_Q_abs in nmaj. + apply CR_of_Q_le. destruct (Q_dec (Qabs (qn i + - qn j)) (1#p)). + destruct s. apply Qlt_le_weak, q. exfalso. + apply (Qlt_not_le _ _ q). apply (CR_of_Q_lt R1) in q. contradiction. + rewrite q. apply Qle_refl. +Qed. + +Definition CR_Q_limit {R : ConstructiveReals} (x : CRcarrier R) (n:nat) + : { q:Q & x < CR_of_Q R q < x + CR_of_Q R (1 # Pos.of_nat n) }. +Proof. + apply (CR_Q_dense R x (x + CR_of_Q R (1 # Pos.of_nat n))). + rewrite <- (CRplus_0_r x). rewrite CRplus_assoc. + apply CRplus_lt_compat_l. rewrite CRplus_0_l. apply CR_of_Q_pos. + reflexivity. +Qed. + +Lemma CR_Q_limit_cv : forall {R : ConstructiveReals} (x : CRcarrier R), + CR_cv R (fun n => CR_of_Q R (let (q,_) := CR_Q_limit x n in q)) x. +Proof. + intros R x p. exists (Pos.to_nat p). + intros. destruct (CR_Q_limit x i). rewrite CRabs_right. + apply (CRplus_le_reg_r x). unfold CRminus. + rewrite CRplus_assoc, CRplus_opp_l, CRplus_0_r, CRplus_comm. + apply (CRle_trans _ (x + CR_of_Q R (1 # Pos.of_nat i))). + apply CRlt_asym, p0. apply CRplus_le_compat_l, CR_of_Q_le. + unfold Qle, Qnum, Qden. rewrite Z.mul_1_l, Z.mul_1_l. + apply Pos2Z.pos_le_pos, Pos2Nat.inj_le. rewrite Nat2Pos.id. exact H. + destruct i. exfalso. inversion H. pose proof (Pos2Nat.is_pos p). + rewrite H1 in H0. inversion H0. discriminate. + rewrite <- (CRplus_opp_r x). apply CRplus_le_compat_r, CRlt_asym, p0. +Qed. + +(* We call this morphism slow to remind that it should only be used + for proofs, not for computations. *) +Definition SlowMorph {R1 R2 : ConstructiveReals} + : CRcarrier R1 -> CRcarrier R2 + := fun x => let (y,_) := CR_complete R2 _ (CRmorph_rat_cv _ (Rcv_cauchy_mod _ x (CR_Q_limit_cv x))) + in y. + +Lemma CauchyMorph_rat : forall {R1 R2 : ConstructiveReals} (q : Q), + SlowMorph (CR_of_Q R1 q) == CR_of_Q R2 q. +Proof. + intros. unfold SlowMorph. + destruct (CR_complete R2 _ + (CRmorph_rat_cv _ + (Rcv_cauchy_mod + (fun n : nat => CR_of_Q R1 (let (q0, _) := CR_Q_limit (CR_of_Q R1 q) n in q0)) + (CR_of_Q R1 q) (CR_Q_limit_cv (CR_of_Q R1 q))))). + apply (CR_cv_unique _ _ _ c). + intro p. exists (Pos.to_nat p). intros. + destruct (CR_Q_limit (CR_of_Q R1 q) i). rewrite CRabs_right. + apply (CRplus_le_reg_r (CR_of_Q R2 q)). unfold CRminus. + rewrite CRplus_assoc, CRplus_opp_l, CRplus_0_r, CRplus_comm. + rewrite <- CR_of_Q_plus. apply CR_of_Q_le. + destruct (Q_dec x0 (q + (1 # p))%Q). destruct s. + apply Qlt_le_weak, q0. exfalso. pose proof (CR_of_Q_lt R1 _ _ q0). + apply (CRlt_asym _ _ H0). apply (CRlt_le_trans _ _ _ (snd p0)). clear H0. + rewrite <- CR_of_Q_plus. apply CR_of_Q_le. apply Qplus_le_r. + unfold Qle, Qnum, Qden. rewrite Z.mul_1_l, Z.mul_1_l. + apply Pos2Z.pos_le_pos, Pos2Nat.inj_le. rewrite Nat2Pos.id. exact H. + destruct i. exfalso. inversion H. pose proof (Pos2Nat.is_pos p). + rewrite H1 in H0. inversion H0. discriminate. + rewrite q0. apply Qle_refl. + rewrite <- (CRplus_opp_r (CR_of_Q R2 q)). apply CRplus_le_compat_r, CR_of_Q_le. + destruct (Q_dec q x0). destruct s. apply Qlt_le_weak, q0. + exfalso. apply (CRlt_asym _ _ (fst p0)). apply CR_of_Q_lt. exact q0. + rewrite q0. apply Qle_refl. +Qed. + +(* The increasing property of morphisms, when the left bound is rational. *) +Lemma SlowMorph_increasing_Qr + : forall {R1 R2 : ConstructiveReals} (x : CRcarrier R1) (q : Q), + CR_of_Q R1 q < x -> CR_of_Q R2 q < SlowMorph x. +Proof. + intros. + unfold SlowMorph; + destruct (CR_complete R2 _ + (CRmorph_rat_cv _ + (Rcv_cauchy_mod (fun n : nat => CR_of_Q R1 (let (q0, _) := CR_Q_limit x n in q0)) x + (CR_Q_limit_cv x)))). + destruct (CR_Q_dense R1 _ _ H) as [r [H0 H1]]. + apply lt_CR_of_Q in H0. + apply (CRlt_le_trans _ (CR_of_Q R2 r)). + apply CR_of_Q_lt, H0. + assert (forall n:nat, le O n -> CR_of_Q R2 r <= CR_of_Q R2 (let (q0, _) := CR_Q_limit x n in q0)). + { intros. apply CR_of_Q_le. destruct (CR_Q_limit x n). + destruct (Q_dec r x1). destruct s. apply Qlt_le_weak, q0. + exfalso. apply (CR_of_Q_lt R1) in q0. + apply (CRlt_asym _ _ q0). exact (CRlt_trans _ _ _ H1 (fst p)). + rewrite q0. apply Qle_refl. } + exact (CR_cv_bound_down _ _ _ O H2 c). +Qed. + +(* The increasing property of morphisms, when the right bound is rational. *) +Lemma SlowMorph_increasing_Ql + : forall {R1 R2 : ConstructiveReals} (x : CRcarrier R1) (q : Q), + x < CR_of_Q R1 q -> SlowMorph x < CR_of_Q R2 q. +Proof. + intros. + unfold SlowMorph; + destruct (CR_complete R2 _ + (CRmorph_rat_cv _ + (Rcv_cauchy_mod (fun n : nat => CR_of_Q R1 (let (q0, _) := CR_Q_limit x n in q0)) x + (CR_Q_limit_cv x)))). + assert (CR_cv R1 (fun n => CR_of_Q R1 (let (q0, _) := CR_Q_limit x n in q0) + + CR_of_Q R1 (1 # Pos.of_nat n)) x). + { apply (CR_cv_proper _ (x+0)). apply CR_cv_plus. apply CR_Q_limit_cv. + intro p. exists (Pos.to_nat p). intros. + unfold CRminus. rewrite CRopp_0, CRplus_0_r. rewrite CRabs_right. + apply CR_of_Q_le. unfold Qle, Qnum, Qden. do 2 rewrite Z.mul_1_l. + apply Pos2Z.pos_le_pos, Pos2Nat.inj_le. rewrite Nat2Pos.id. exact H0. + destruct i. inversion H0. pose proof (Pos2Nat.is_pos p). + rewrite H2 in H1. inversion H1. discriminate. + rewrite <- CR_of_Q_zero. apply CR_of_Q_le. discriminate. + rewrite CRplus_0_r. reflexivity. } + pose proof (CR_cv_open_above _ _ _ H0 H) as [n nmaj]. + apply (CRle_lt_trans _ (CR_of_Q R2 (let (q0, _) := CR_Q_limit x n in + q0 + (1 # Pos.of_nat n)))). + - apply (CR_cv_bound_up (fun n : nat => CR_of_Q R2 (let (q0, _) := CR_Q_limit x n in q0)) _ _ n). + 2: exact c. intros. destruct (CR_Q_limit x n0), (CR_Q_limit x n). + apply CR_of_Q_le, Qlt_le_weak. apply (lt_CR_of_Q R1). + apply (CRlt_le_trans _ _ _ (snd p)). + apply (CRle_trans _ (CR_of_Q R1 x2 + CR_of_Q R1 (1 # Pos.of_nat n0))). + apply CRplus_le_compat_r. apply CRlt_asym, p0. + rewrite <- CR_of_Q_plus. apply CR_of_Q_le. apply Qplus_le_r. + unfold Qle, Qnum, Qden. do 2 rewrite Z.mul_1_l. + apply Pos2Z.pos_le_pos, Pos2Nat.inj_le. + destruct n. destruct n0. apply le_refl. + rewrite (Nat2Pos.id (S n0)). apply le_n_S, le_0_n. discriminate. + destruct n0. exfalso; inversion H1. + rewrite Nat2Pos.id, Nat2Pos.id. exact H1. discriminate. discriminate. + - specialize (nmaj n (le_refl n)). + destruct (CR_Q_limit x n). apply CR_of_Q_lt. + rewrite <- CR_of_Q_plus in nmaj. apply lt_CR_of_Q in nmaj. exact nmaj. +Qed. + +Lemma SlowMorph_increasing : forall {R1 R2 : ConstructiveReals} (x y : CRcarrier R1), + x < y -> @SlowMorph R1 R2 x < SlowMorph y. +Proof. + intros. + destruct (CR_Q_dense R1 _ _ H) as [q [H0 H1]]. + apply (CRlt_trans _ (CR_of_Q R2 q)). + apply SlowMorph_increasing_Ql. exact H0. + apply SlowMorph_increasing_Qr. exact H1. +Qed. + + +(* We call this morphism slow to remind that it should only be used + for proofs, not for computations. *) +Definition SlowConstructiveRealsMorphism {R1 R2 : ConstructiveReals} + : @ConstructiveRealsMorphism R1 R2 + := Build_ConstructiveRealsMorphism + R1 R2 SlowMorph CauchyMorph_rat + SlowMorph_increasing. + +Lemma CRmorph_abs : forall {R1 R2 : ConstructiveReals} + (f : @ConstructiveRealsMorphism R1 R2) + (x : CRcarrier R1), + CRabs R2 (CRmorph f x) == CRmorph f (CRabs R1 x). +Proof. + assert (forall {R1 R2 : ConstructiveReals} + (f : @ConstructiveRealsMorphism R1 R2) + (x : CRcarrier R1), + CRabs R2 (CRmorph f x) <= CRmorph f (CRabs R1 x)). + { intros. rewrite <- CRabs_def. split. + - apply CRmorph_le. + pose proof (CRabs_def _ x (CRabs R1 x)) as [_ H]. + apply H, CRle_refl. + - apply (CRle_trans _ (CRmorph f (CRopp R1 x))). + apply CRmorph_opp. apply CRmorph_le. + pose proof (CRabs_def _ x (CRabs R1 x)) as [_ H]. + apply H, CRle_refl. } + intros. split. 2: apply H. + apply (CRmorph_le_inv (@SlowConstructiveRealsMorphism R2 R1)). + apply (CRle_trans _ (CRabs R1 x)). + apply (Endomorph_id + (CRmorph_compose f (@SlowConstructiveRealsMorphism R2 R1))). + apply (CRle_trans + _ (CRabs R1 (CRmorph (@SlowConstructiveRealsMorphism R2 R1) (CRmorph f x)))). + apply CRabs_morph. + apply CReq_sym, (Endomorph_id + (CRmorph_compose f (@SlowConstructiveRealsMorphism R2 R1))). + apply H. +Qed. + +Lemma CRmorph_cv : forall {R1 R2 : ConstructiveReals} + (f : @ConstructiveRealsMorphism R1 R2) + (un : nat -> CRcarrier R1) + (l : CRcarrier R1), + CR_cv R1 un l + -> CR_cv R2 (fun n => CRmorph f (un n)) (CRmorph f l). +Proof. + intros. intro p. specialize (H p) as [n H]. + exists n. intros. specialize (H i H0). + unfold CRminus. rewrite <- CRmorph_opp, <- CRmorph_plus, CRmorph_abs. + rewrite <- (CRmorph_rat f (1#p)). apply CRmorph_le. exact H. +Qed. + +Lemma CRmorph_cauchy_reverse : forall {R1 R2 : ConstructiveReals} + (f : @ConstructiveRealsMorphism R1 R2) + (un : nat -> CRcarrier R1), + CR_cauchy R2 (fun n => CRmorph f (un n)) + -> CR_cauchy R1 un. +Proof. + intros. intro p. specialize (H p) as [n H]. + exists n. intros. specialize (H i j H0 H1). + unfold CRminus in H. rewrite <- CRmorph_opp, <- CRmorph_plus, CRmorph_abs in H. + rewrite <- (CRmorph_rat f (1#p)) in H. + apply (CRmorph_le_inv f) in H. exact H. +Qed. + +Lemma CRmorph_min : forall {R1 R2 : ConstructiveReals} + (f : @ConstructiveRealsMorphism R1 R2) + (a b : CRcarrier R1), + CRmorph f (CRmin a b) + == CRmin (CRmorph f a) (CRmorph f b). +Proof. + intros. unfold CRmin. + rewrite CRmorph_mult. apply CRmult_morph. + 2: apply CRmorph_rat. + unfold CRminus. do 2 rewrite CRmorph_plus. apply CRplus_morph. + apply CRplus_morph. reflexivity. reflexivity. + rewrite CRmorph_opp. apply CRopp_morph. + rewrite <- CRmorph_abs. apply CRabs_morph. + rewrite CRmorph_plus. apply CRplus_morph. + reflexivity. + rewrite CRmorph_opp. apply CRopp_morph, CRmorph_proper. reflexivity. +Qed. + +Lemma CRmorph_series_cv : forall {R1 R2 : ConstructiveReals} + (f : @ConstructiveRealsMorphism R1 R2) + (un : nat -> CRcarrier R1) + (l : CRcarrier R1), + series_cv un l + -> series_cv (fun n => CRmorph f (un n)) (CRmorph f l). +Proof. + intros. + apply (CR_cv_eq _ (fun n => CRmorph f (CRsum un n))). + intro n. apply CRmorph_sum. + apply CRmorph_cv, H. +Qed. diff --git a/theories/Reals/Abstract/ConstructiveSum.v b/theories/Reals/Abstract/ConstructiveSum.v new file mode 100644 index 0000000000..11c8e5d8a2 --- /dev/null +++ b/theories/Reals/Abstract/ConstructiveSum.v @@ -0,0 +1,348 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +Require Import QArith Qabs. +Require Import ConstructiveReals. +Require Import ConstructiveAbs. + +Local Open Scope ConstructiveReals. + + +(** + Definition and properties of finite sums and powers. +*) + +Fixpoint CRsum {R : ConstructiveReals} + (f:nat -> CRcarrier R) (N:nat) : CRcarrier R := + match N with + | O => f 0%nat + | S i => CRsum f i + f (S i) + end. + +Fixpoint CRpow {R : ConstructiveReals} (r:CRcarrier R) (n:nat) : CRcarrier R := + match n with + | O => 1 + | S n => r * (CRpow r n) + end. + +Lemma CRsum_eq : + forall {R : ConstructiveReals} (An Bn:nat -> CRcarrier R) (N:nat), + (forall i:nat, (i <= N)%nat -> An i == Bn i) -> + CRsum An N == CRsum Bn N. +Proof. + induction N. + - intros. exact (H O (le_refl _)). + - intros. simpl. apply CRplus_morph. apply IHN. + intros. apply H. apply (le_trans _ N _ H0), le_S, le_refl. + apply H, le_refl. +Qed. + +Lemma sum_eq_R0 : forall {R : ConstructiveReals} (un : nat -> CRcarrier R) (n : nat), + (forall k:nat, un k == 0) + -> CRsum un n == 0. +Proof. + induction n. + - intros. apply H. + - intros. simpl. rewrite IHn. rewrite H. apply CRplus_0_l. exact H. +Qed. + +Definition INR {R : ConstructiveReals} (n : nat) : CRcarrier R + := CR_of_Q R (Z.of_nat n # 1). + +Lemma sum_const : forall {R : ConstructiveReals} (a : CRcarrier R) (n : nat), + CRsum (fun _ => a) n == a * INR (S n). +Proof. + induction n. + - unfold INR. simpl. rewrite CR_of_Q_one, CRmult_1_r. reflexivity. + - simpl. rewrite IHn. unfold INR. + replace (Z.of_nat (S (S n))) with (Z.of_nat (S n) + 1)%Z. + rewrite <- Qinv_plus_distr, CR_of_Q_plus, CRmult_plus_distr_l. + apply CRplus_morph. reflexivity. rewrite CR_of_Q_one, CRmult_1_r. reflexivity. + replace 1%Z with (Z.of_nat 1). rewrite <- Nat2Z.inj_add. + apply f_equal. rewrite Nat.add_comm. reflexivity. reflexivity. +Qed. + +Lemma multiTriangleIneg : forall {R : ConstructiveReals} (u : nat -> CRcarrier R) (n : nat), + CRabs R (CRsum u n) <= CRsum (fun k => CRabs R (u k)) n. +Proof. + induction n. + - apply CRle_refl. + - simpl. apply (CRle_trans _ (CRabs R (CRsum u n) + CRabs R (u (S n)))). + apply CRabs_triang. apply CRplus_le_compat. apply IHn. + apply CRle_refl. +Qed. + +Lemma sum_assoc : forall {R : ConstructiveReals} (u : nat -> CRcarrier R) (n p : nat), + CRsum u (S n + p) + == CRsum u n + CRsum (fun k => u (S n + k)%nat) p. +Proof. + induction p. + - simpl. rewrite Nat.add_0_r. reflexivity. + - simpl. rewrite (Radd_assoc (CRisRing R)). apply CRplus_morph. + rewrite Nat.add_succ_r. + rewrite (CRsum_eq (fun k : nat => u (S (n + k))) (fun k : nat => u (S n + k)%nat)). + rewrite <- IHp. reflexivity. intros. reflexivity. reflexivity. +Qed. + +Lemma sum_Rle : forall {R : ConstructiveReals} (un vn : nat -> CRcarrier R) (n : nat), + (forall k, le k n -> un k <= vn k) + -> CRsum un n <= CRsum vn n. +Proof. + induction n. + - intros. apply H. apply le_refl. + - intros. simpl. apply CRplus_le_compat. apply IHn. + intros. apply H. apply (le_trans _ n _ H0). apply le_S, le_refl. + apply H. apply le_refl. +Qed. + +Lemma Abs_sum_maj : forall {R : ConstructiveReals} (un vn : nat -> CRcarrier R), + (forall n:nat, CRabs R (un n) <= (vn n)) + -> forall n p:nat, (CRabs R (CRsum un n - CRsum un p) <= + CRsum vn (Init.Nat.max n p) - CRsum vn (Init.Nat.min n p)). +Proof. + intros. destruct (le_lt_dec n p). + - destruct (Nat.le_exists_sub n p) as [k [maj _]]. assumption. + subst p. rewrite max_r. rewrite min_l. + setoid_replace (CRsum un n - CRsum un (k + n)) + with (-(CRsum un (k + n) - CRsum un n)). + rewrite CRabs_opp. + destruct k. simpl. unfold CRminus. rewrite CRplus_opp_r. + rewrite CRplus_opp_r. rewrite CRabs_right. + apply CRle_refl. apply CRle_refl. + replace (S k + n)%nat with (S n + k)%nat. + unfold CRminus. rewrite sum_assoc. rewrite sum_assoc. + rewrite CRplus_comm. + rewrite <- CRplus_assoc. rewrite CRplus_opp_l. + rewrite CRplus_0_l. rewrite CRplus_comm. + rewrite <- CRplus_assoc. rewrite CRplus_opp_l. + rewrite CRplus_0_l. + apply (CRle_trans _ (CRsum (fun k0 : nat => CRabs R (un (S n + k0)%nat)) k)). + apply multiTriangleIneg. apply sum_Rle. intros. + apply H. rewrite Nat.add_comm, Nat.add_succ_r. reflexivity. + unfold CRminus. rewrite CRopp_plus_distr, CRopp_involutive, CRplus_comm. + reflexivity. assumption. assumption. + - destruct (Nat.le_exists_sub p n) as [k [maj _]]. unfold lt in l. + apply (le_trans p (S p)). apply le_S. apply le_refl. assumption. + subst n. rewrite max_l. rewrite min_r. + destruct k. simpl. unfold CRminus. rewrite CRplus_opp_r. + rewrite CRplus_opp_r. rewrite CRabs_right. apply CRle_refl. + apply CRle_refl. + replace (S k + p)%nat with (S p + k)%nat. unfold CRminus. + rewrite sum_assoc. rewrite sum_assoc. + rewrite CRplus_comm. + rewrite <- CRplus_assoc. rewrite CRplus_opp_l. + rewrite CRplus_0_l. rewrite CRplus_comm. + rewrite <- CRplus_assoc. rewrite CRplus_opp_l. + rewrite CRplus_0_l. + apply (CRle_trans _ (CRsum (fun k0 : nat => CRabs R (un (S p + k0)%nat)) k)). + apply multiTriangleIneg. apply sum_Rle. intros. + apply H. rewrite Nat.add_comm, Nat.add_succ_r. reflexivity. + apply (le_trans p (S p)). apply le_S. apply le_refl. assumption. + apply (le_trans p (S p)). apply le_S. apply le_refl. assumption. +Qed. + +Lemma cond_pos_sum : forall {R : ConstructiveReals} (un : nat -> CRcarrier R) (n : nat), + (forall k, 0 <= un k) + -> 0 <= CRsum un n. +Proof. + induction n. + - intros. apply H. + - intros. simpl. rewrite <- CRplus_0_r. + apply CRplus_le_compat. apply IHn, H. apply H. +Qed. + +Lemma pos_sum_more : forall {R : ConstructiveReals} (u : nat -> CRcarrier R) + (n p : nat), + (forall k:nat, 0 <= u k) + -> le n p -> CRsum u n <= CRsum u p. +Proof. + intros. destruct (Nat.le_exists_sub n p H0). destruct H1. subst p. + rewrite plus_comm. + destruct x. rewrite plus_0_r. apply CRle_refl. rewrite Nat.add_succ_r. + replace (S (n + x)) with (S n + x)%nat. rewrite sum_assoc. + rewrite <- CRplus_0_r, CRplus_assoc. + apply CRplus_le_compat_l. rewrite CRplus_0_l. + apply cond_pos_sum. + intros. apply H. auto. +Qed. + +Lemma sum_opp : forall {R : ConstructiveReals} (un : nat -> CRcarrier R) (n : nat), + CRsum (fun k => - un k) n == - CRsum un n. +Proof. + induction n. + - reflexivity. + - simpl. rewrite IHn. rewrite CRopp_plus_distr. reflexivity. +Qed. + +Lemma sum_scale : forall {R : ConstructiveReals} (u : nat -> CRcarrier R) (a : CRcarrier R) (n : nat), + CRsum (fun k : nat => u k * a) n == CRsum u n * a. +Proof. + induction n. + - simpl. rewrite (Rmul_comm (CRisRing R)). reflexivity. + - simpl. rewrite IHn. rewrite CRmult_plus_distr_r. + apply CRplus_morph. reflexivity. + rewrite (Rmul_comm (CRisRing R)). reflexivity. +Qed. + +Lemma sum_plus : forall {R : ConstructiveReals} (u v : nat -> CRcarrier R) (n : nat), + CRsum (fun n0 : nat => u n0 + v n0) n == CRsum u n + CRsum v n. +Proof. + induction n. + - reflexivity. + - simpl. rewrite IHn. do 2 rewrite CRplus_assoc. + apply CRplus_morph. reflexivity. rewrite CRplus_comm, CRplus_assoc. + apply CRplus_morph. reflexivity. apply CRplus_comm. +Qed. + +Lemma decomp_sum : + forall {R : ConstructiveReals} (An:nat -> CRcarrier R) (N:nat), + (0 < N)%nat -> + CRsum An N == An 0%nat + CRsum (fun i:nat => An (S i)) (pred N). +Proof. + induction N. + - intros. exfalso. inversion H. + - intros _. destruct N. simpl. reflexivity. simpl. + rewrite IHN. rewrite CRplus_assoc. + apply CRplus_morph. reflexivity. reflexivity. + apply le_n_S, le_0_n. +Qed. + +Lemma reverse_sum : forall {R : ConstructiveReals} (u : nat -> CRcarrier R) (n : nat), + CRsum u n == CRsum (fun k => u (n-k)%nat) n. +Proof. + induction n. + - intros. reflexivity. + - rewrite (decomp_sum (fun k : nat => u (S n - k)%nat)). simpl. + rewrite CRplus_comm. apply CRplus_morph. reflexivity. assumption. + unfold lt. apply le_n_S. apply le_0_n. +Qed. + +Lemma Rplus_le_pos : forall {R : ConstructiveReals} (a b : CRcarrier R), + 0 <= b -> a <= a + b. +Proof. + intros. rewrite <- (CRplus_0_r a). rewrite CRplus_assoc. + apply CRplus_le_compat_l. rewrite CRplus_0_l. assumption. +Qed. + +Lemma selectOneInSum : forall {R : ConstructiveReals} (u : nat -> CRcarrier R) (n i : nat), + le i n + -> (forall k:nat, 0 <= u k) + -> u i <= CRsum u n. +Proof. + induction n. + - intros. inversion H. subst i. apply CRle_refl. + - intros. apply Nat.le_succ_r in H. destruct H. + apply (CRle_trans _ (CRsum u n)). apply IHn. assumption. assumption. + simpl. apply Rplus_le_pos. apply H0. + subst i. simpl. rewrite CRplus_comm. apply Rplus_le_pos. + apply cond_pos_sum. intros. apply H0. +Qed. + +Lemma splitSum : forall {R : ConstructiveReals} (un : nat -> CRcarrier R) + (filter : nat -> bool) (n : nat), + CRsum un n + == CRsum (fun i => if filter i then un i else 0) n + + CRsum (fun i => if filter i then 0 else un i) n. +Proof. + induction n. + - simpl. destruct (filter O). symmetry; apply CRplus_0_r. + symmetry. apply CRplus_0_l. + - simpl. rewrite IHn. clear IHn. destruct (filter (S n)). + do 2 rewrite CRplus_assoc. apply CRplus_morph. reflexivity. + rewrite CRplus_comm. apply CRplus_morph. reflexivity. rewrite CRplus_0_r. + reflexivity. rewrite CRplus_0_r. rewrite CRplus_assoc. reflexivity. +Qed. + + +(* Power *) + +Lemma pow_R1_Rle : forall {R : ConstructiveReals} (x : CRcarrier R) (n : nat), + 1 <= x + -> 1 <= CRpow x n. +Proof. + induction n. + - intros. apply CRle_refl. + - intros. simpl. apply (CRle_trans _ (x * 1)). + rewrite CRmult_1_r. exact H. + apply CRmult_le_compat_l_half. apply (CRlt_le_trans _ 1). + apply CRzero_lt_one. exact H. + apply IHn. exact H. +Qed. + +Lemma pow_le : forall {R : ConstructiveReals} (x : CRcarrier R) (n : nat), + 0 <= x + -> 0 <= CRpow x n. +Proof. + induction n. + - intros. apply CRlt_asym, CRzero_lt_one. + - intros. simpl. apply CRmult_le_0_compat. + exact H. apply IHn. exact H. +Qed. + +Lemma pow_lt : forall {R : ConstructiveReals} (x : CRcarrier R) (n : nat), + 0 < x + -> 0 < CRpow x n. +Proof. + induction n. + - intros. apply CRzero_lt_one. + - intros. simpl. apply CRmult_lt_0_compat. exact H. + apply IHn. exact H. +Qed. + +Lemma pow_mult : forall {R : ConstructiveReals} (x y : CRcarrier R) (n:nat), + CRpow x n * CRpow y n == CRpow (x*y) n. +Proof. + induction n. + - simpl. rewrite CRmult_1_r. reflexivity. + - simpl. rewrite <- IHn. do 2 rewrite <- (Rmul_assoc (CRisRing R)). + apply CRmult_morph. reflexivity. + rewrite <- (Rmul_comm (CRisRing R)). rewrite <- (Rmul_assoc (CRisRing R)). + apply CRmult_morph. reflexivity. + rewrite <- (Rmul_comm (CRisRing R)). reflexivity. +Qed. + +Lemma pow_one : forall {R : ConstructiveReals} (n:nat), + @CRpow R 1 n == 1. +Proof. + induction n. reflexivity. + transitivity (CRmult R 1 (CRpow 1 n)). reflexivity. + rewrite IHn. rewrite CRmult_1_r. reflexivity. +Qed. + +Lemma pow_proper : forall {R : ConstructiveReals} (x y : CRcarrier R) (n : nat), + x == y -> CRpow x n == CRpow y n. +Proof. + induction n. + - intros. reflexivity. + - intros. simpl. rewrite IHn, H. reflexivity. exact H. +Qed. + +Lemma pow_inv : forall {R : ConstructiveReals} (x : CRcarrier R) (xPos : 0 < x) (n : nat), + CRpow (CRinv R x (inr xPos)) n + == CRinv R (CRpow x n) (inr (pow_lt x n xPos)). +Proof. + induction n. + - rewrite CRinv_1. reflexivity. + - transitivity (CRinv R x (inr xPos) * CRpow (CRinv R x (inr xPos)) n). + reflexivity. rewrite IHn. + assert (0 < x * CRpow x n). + { apply CRmult_lt_0_compat. exact xPos. apply pow_lt, xPos. } + rewrite <- (CRinv_mult_distr _ _ _ _ (inr H)). + apply CRinv_morph. reflexivity. +Qed. + +Lemma pow_plus_distr : forall {R : ConstructiveReals} (x : CRcarrier R) (n p:nat), + CRpow x n * CRpow x p == CRpow x (n+p). +Proof. + induction n. + - intros. simpl. rewrite CRmult_1_l. reflexivity. + - intros. simpl. rewrite CRmult_assoc. apply CRmult_morph. + reflexivity. apply IHn. +Qed. diff --git a/theories/Reals/Cauchy/ConstructiveCauchyAbs.v b/theories/Reals/Cauchy/ConstructiveCauchyAbs.v new file mode 100644 index 0000000000..7e51b575ba --- /dev/null +++ b/theories/Reals/Cauchy/ConstructiveCauchyAbs.v @@ -0,0 +1,887 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +Require Import QArith. +Require Import Qabs. +Require Import ConstructiveCauchyReals. +Require Import ConstructiveCauchyRealsMult. + +Local Open Scope CReal_scope. + + +(** + The constructive formulation of the absolute value on the real numbers. + This is followed by the constructive definitions of minimum and maximum, + as min x y := (x + y - |x-y|) / 2. +*) + + +(* If a rational sequence is Cauchy, then so is its absolute value. + This is how the constructive absolute value is defined. + A more abstract way to put it is the real numbers are the metric completion + of the rational numbers, so the uniformly continuous function + Qabs : Q -> Q + uniquely extends to a uniformly continuous function + CReal_abs : CReal -> CReal +*) +Lemma CauchyAbsStable : forall xn : nat -> Q, + QCauchySeq xn Pos.to_nat + -> QCauchySeq (fun n => Qabs (xn n)) Pos.to_nat. +Proof. + intros xn cau n p q H H0. + specialize (cau n p q H H0). + apply (Qle_lt_trans _ (Qabs (xn p - xn q))). + 2: exact cau. apply Qabs_Qle_condition. split. + 2: apply Qabs_triangle_reverse. + apply (Qplus_le_r _ _ (Qabs (xn q))). + rewrite <- Qabs_opp. + apply (Qle_trans _ _ _ (Qabs_triangle_reverse _ _)). + ring_simplify. + setoid_replace (-xn q - (xn p - xn q))%Q with (-(xn p))%Q. + 2: ring. rewrite Qabs_opp. apply Qle_refl. +Qed. + +Definition CReal_abs (x : CReal) : CReal + := let (xn, cau) := x in + exist _ (fun n => Qabs (xn n)) (CauchyAbsStable xn cau). + +Lemma CReal_neg_nth : forall (x : CReal) (n : positive), + (proj1_sig x (Pos.to_nat n) < -1#n)%Q + -> x < 0. +Proof. + intros. destruct x as [xn cau]; unfold proj1_sig in H. + apply Qlt_minus_iff in H. + setoid_replace ((-1 # n) + - xn (Pos.to_nat n))%Q + with (- ((1 # n) + xn (Pos.to_nat n)))%Q in H. + destruct (Qarchimedean (2 / (-((1#n) + xn (Pos.to_nat n))))) as [k kmaj]. + exists (Pos.max k n). simpl. unfold Qminus; rewrite Qplus_0_l. + specialize (cau n (Pos.to_nat n) (max (Pos.to_nat k) (Pos.to_nat n)) + (le_refl _) (Nat.le_max_r _ _)). + apply (Qle_lt_trans _ (2#k)). + unfold Qle, Qnum, Qden. + apply Z.mul_le_mono_nonneg_l. discriminate. + apply Pos2Z.pos_le_pos, Pos.le_max_l. + rewrite <- Pos2Nat.inj_max in cau. + apply (Qmult_lt_l _ _ (-((1 # n) + xn (Pos.to_nat n)))) in kmaj. + rewrite Qmult_div_r in kmaj. + apply (Qmult_lt_r _ _ (1 # k)) in kmaj. + rewrite <- Qmult_assoc in kmaj. + setoid_replace ((Z.pos k # 1) * (1 # k))%Q with 1%Q in kmaj. + rewrite Qmult_1_r in kmaj. + setoid_replace (2#k)%Q with (2 * (1 # k))%Q. 2: reflexivity. + apply (Qlt_trans _ _ _ kmaj). clear kmaj. + apply (Qplus_lt_l _ _ ((1#n) + xn (Pos.to_nat (Pos.max k n)))). + ring_simplify. rewrite Qplus_comm. + apply (Qle_lt_trans _ (Qabs (xn (Pos.to_nat n) - xn (Pos.to_nat (Pos.max k n))))). + 2: exact cau. + rewrite <- Qabs_opp. + setoid_replace (- (xn (Pos.to_nat n) - xn (Pos.to_nat (Pos.max k n))))%Q + with (xn (Pos.to_nat (Pos.max k n)) + -1 * xn (Pos.to_nat n))%Q. + apply Qle_Qabs. ring. 2: reflexivity. + unfold Qmult, Qeq, Qnum, Qden. + rewrite Z.mul_1_r, Z.mul_1_r, Z.mul_1_l. reflexivity. + 2: exact H. intro abs. rewrite abs in H. exact (Qlt_irrefl 0 H). + setoid_replace (-1 # n)%Q with (-(1#n))%Q. ring. reflexivity. +Qed. + +Lemma CReal_nonneg : forall (x : CReal) (n : positive), + 0 <= x -> (-1#n <= proj1_sig x (Pos.to_nat n))%Q. +Proof. + intros. destruct x as [xn cau]; unfold proj1_sig. + destruct (Qlt_le_dec (xn (Pos.to_nat n)) (-1#n)). + 2: exact q. exfalso. apply H. clear H. + apply (CReal_neg_nth _ n). exact q. +Qed. + +Lemma CReal_abs_right : forall x : CReal, 0 <= x -> CReal_abs x == x. +Proof. + intros. apply CRealEq_diff. intro n. + destruct x as [xn cau]; unfold CReal_abs, proj1_sig. + apply (CReal_nonneg _ n) in H. simpl in H. + rewrite Qabs_pos. + 2: unfold Qminus; rewrite <- Qle_minus_iff; apply Qle_Qabs. + destruct (Qlt_le_dec (xn (Pos.to_nat n)) 0). + - rewrite Qabs_neg. 2: apply Qlt_le_weak, q. + apply Qopp_le_compat in H. + apply (Qmult_le_l _ _ (1#2)). reflexivity. ring_simplify. + setoid_replace ((1 # 2) * (2 # n))%Q with (-(-1#n))%Q. + 2: reflexivity. + setoid_replace ((-2 # 2) * xn (Pos.to_nat n))%Q with (- xn (Pos.to_nat n))%Q. + exact H. ring. + - rewrite Qabs_pos. unfold Qminus. rewrite Qplus_opp_r. discriminate. exact q. +Qed. + +Lemma CReal_le_abs : forall x : CReal, x <= CReal_abs x. +Proof. + intros. intros [n nmaj]. destruct x as [xn cau]; simpl in nmaj. + apply (Qle_not_lt _ _ (Qle_Qabs (xn (Pos.to_nat n)))). + apply Qlt_minus_iff. apply (Qlt_trans _ (2#n)). + reflexivity. exact nmaj. +Qed. + +Lemma CReal_abs_pos : forall x : CReal, 0 <= CReal_abs x. +Proof. + intros. intros [n nmaj]. destruct x as [xn cau]; simpl in nmaj. + apply (Qle_not_lt _ _ (Qabs_nonneg (xn (Pos.to_nat n)))). + apply Qlt_minus_iff. apply (Qlt_trans _ (2#n)). + reflexivity. exact nmaj. +Qed. + +Lemma CReal_abs_opp : forall x : CReal, CReal_abs (-x) == CReal_abs x. +Proof. + intros. apply CRealEq_diff. intro n. + destruct x as [xn cau]; unfold CReal_abs, CReal_opp, proj1_sig. + rewrite Qabs_opp. unfold Qminus. rewrite Qplus_opp_r. + discriminate. +Qed. + +Lemma CReal_abs_left : forall x : CReal, x <= 0 -> CReal_abs x == -x. +Proof. + intros. + apply CReal_opp_ge_le_contravar in H. rewrite CReal_opp_0 in H. + rewrite <- CReal_abs_opp. apply CReal_abs_right, H. +Qed. + +Lemma CReal_abs_appart_0 : forall x : CReal, + 0 < CReal_abs x -> x # 0. +Proof. + intros x [n nmaj]. destruct x as [xn cau]; simpl in nmaj. + destruct (Qlt_le_dec (xn (Pos.to_nat n)) 0). + - left. exists n. simpl. rewrite Qabs_neg in nmaj. + apply (Qlt_le_trans _ _ _ nmaj). ring_simplify. apply Qle_refl. + apply Qlt_le_weak, q. + - right. exists n. simpl. rewrite Qabs_pos in nmaj. + exact nmaj. exact q. +Qed. + +Add Parametric Morphism : CReal_abs + with signature CRealEq ==> CRealEq + as CReal_abs_morph. +Proof. + intros. split. + - intro abs. destruct (CReal_abs_appart_0 y). + apply (CReal_le_lt_trans _ (CReal_abs x)). + apply CReal_abs_pos. apply abs. + rewrite CReal_abs_left, CReal_abs_left, H in abs. + exact (CRealLt_asym _ _ abs abs). apply CRealLt_asym, c. + rewrite H. apply CRealLt_asym, c. + rewrite CReal_abs_right, CReal_abs_right, H in abs. + exact (CRealLt_asym _ _ abs abs). apply CRealLt_asym, c. + rewrite H. apply CRealLt_asym, c. + - intro abs. destruct (CReal_abs_appart_0 x). + apply (CReal_le_lt_trans _ (CReal_abs y)). + apply CReal_abs_pos. apply abs. + rewrite CReal_abs_left, CReal_abs_left, H in abs. + exact (CRealLt_asym _ _ abs abs). apply CRealLt_asym, c. + rewrite <- H. apply CRealLt_asym, c. + rewrite CReal_abs_right, CReal_abs_right, H in abs. + exact (CRealLt_asym _ _ abs abs). apply CRealLt_asym, c. + rewrite <- H. apply CRealLt_asym, c. +Qed. + +Lemma CReal_abs_le : forall a b:CReal, -b <= a <= b -> CReal_abs a <= b. +Proof. + intros a b H [n nmaj]. destruct a as [an cau]; simpl in nmaj. + destruct (Qlt_le_dec (an (Pos.to_nat n)) 0). + - rewrite Qabs_neg in nmaj. destruct H. apply H. clear H H0. + exists n. simpl. + destruct b as [bn caub]; simpl; simpl in nmaj. + unfold Qminus. rewrite Qplus_comm. exact nmaj. + apply Qlt_le_weak, q. + - rewrite Qabs_pos in nmaj. destruct H. apply H0. clear H H0. + exists n. simpl. exact nmaj. exact q. +Qed. + +Lemma CReal_abs_minus_sym : forall x y : CReal, + CReal_abs (x - y) == CReal_abs (y - x). +Proof. + intros x y. setoid_replace (x - y) with (-(y-x)). + rewrite CReal_abs_opp. reflexivity. ring. +Qed. + +Lemma CReal_abs_lt : forall x y : CReal, + CReal_abs x < y -> prod (x < y) (-x < y). +Proof. + split. + - apply (CReal_le_lt_trans _ _ _ (CReal_le_abs x)), H. + - apply (CReal_le_lt_trans _ _ _ (CReal_le_abs (-x))). + rewrite CReal_abs_opp. exact H. +Qed. + +Lemma CReal_abs_triang : forall x y : CReal, + CReal_abs (x + y) <= CReal_abs x + CReal_abs y. +Proof. + intros. apply CReal_abs_le. split. + - setoid_replace (x + y) with (-(-x - y)). 2: ring. + apply CReal_opp_ge_le_contravar. + apply CReal_plus_le_compat; rewrite <- CReal_abs_opp; apply CReal_le_abs. + - apply CReal_plus_le_compat; apply CReal_le_abs. +Qed. + +Lemma CReal_abs_triang_inv : forall x y : CReal, + CReal_abs x - CReal_abs y <= CReal_abs (x - y). +Proof. + intros. apply (CReal_plus_le_reg_l (CReal_abs y)). + ring_simplify. rewrite CReal_plus_comm. + apply (CReal_le_trans _ (CReal_abs (x - y + y))). + setoid_replace (x - y + y) with x. apply CRealLe_refl. ring. + apply CReal_abs_triang. +Qed. + +Lemma CReal_abs_triang_inv2 : forall x y : CReal, + CReal_abs (CReal_abs x - CReal_abs y) <= CReal_abs (x - y). +Proof. + intros. apply CReal_abs_le. split. + 2: apply CReal_abs_triang_inv. + apply (CReal_plus_le_reg_r (CReal_abs y)). ring_simplify. + rewrite CReal_plus_comm, CReal_abs_minus_sym. + apply (CReal_le_trans _ _ _ (CReal_abs_triang_inv y (y-x))). + setoid_replace (y - (y - x)) with x. 2: ring. apply CRealLe_refl. +Qed. + +Lemma CReal_abs_gt : forall x : CReal, + x < CReal_abs x -> x < 0. +Proof. + intros x [n nmaj]. destruct x as [xn cau]; simpl in nmaj. + assert (xn (Pos.to_nat n) < 0)%Q. + { destruct (Qlt_le_dec (xn (Pos.to_nat n)) 0). exact q. + exfalso. rewrite Qabs_pos in nmaj. unfold Qminus in nmaj. + rewrite Qplus_opp_r in nmaj. inversion nmaj. exact q. } + rewrite Qabs_neg in nmaj. 2: apply Qlt_le_weak, H. + apply (CReal_neg_nth _ n). simpl. + ring_simplify in nmaj. + apply (Qplus_lt_l _ _ ((1#n) - xn (Pos.to_nat n))). + apply (Qmult_lt_l _ _ 2). reflexivity. ring_simplify. + setoid_replace (2 * (1 # n))%Q with (2 # n)%Q. 2: reflexivity. + rewrite <- Qplus_assoc. + setoid_replace ((2 # n) + 2 * (-1 # n))%Q with 0%Q. + rewrite Qplus_0_r. exact nmaj. + setoid_replace (2*(-1 # n))%Q with (-(2 # n))%Q. + rewrite Qplus_opp_r. reflexivity. reflexivity. +Qed. + +Lemma Rabs_def1 : forall x y : CReal, + x < y -> -x < y -> CReal_abs x < y. +Proof. + intros. apply CRealLt_above in H. apply CRealLt_above in H0. + destruct H as [i imaj]. destruct H0 as [j jmaj]. + exists (Pos.max i j). destruct x as [xn caux], y as [yn cauy]; simpl. + simpl in imaj, jmaj. + destruct (Qlt_le_dec (xn (Pos.to_nat (Pos.max i j))) 0). + - rewrite Qabs_neg. + specialize (jmaj (Pos.max i j) (Pos.le_max_r _ _)). + apply (Qle_lt_trans _ (2#j)). 2: exact jmaj. + unfold Qle, Qnum, Qden. + apply Z.mul_le_mono_nonneg_l. discriminate. + apply Pos2Z.pos_le_pos, Pos.le_max_r. + apply Qlt_le_weak, q. + - rewrite Qabs_pos. + specialize (imaj (Pos.max i j) (Pos.le_max_l _ _)). + apply (Qle_lt_trans _ (2#i)). 2: exact imaj. + unfold Qle, Qnum, Qden. + apply Z.mul_le_mono_nonneg_l. discriminate. + apply Pos2Z.pos_le_pos, Pos.le_max_l. + apply q. +Qed. + +(* The proof by cases on the signs of x and y applies constructively, + because of the positivity hypotheses. *) +Lemma CReal_abs_mult : forall x y : CReal, + CReal_abs (x * y) == CReal_abs x * CReal_abs y. +Proof. + assert (forall x y : CReal, + x # 0 + -> y # 0 + -> CReal_abs (x * y) == CReal_abs x * CReal_abs y) as prep. + { intros. destruct H, H0. + + rewrite CReal_abs_right, CReal_abs_left, CReal_abs_left. ring. + apply CRealLt_asym, c0. apply CRealLt_asym, c. + setoid_replace (x*y) with (- x * - y). + apply CRealLt_asym, CReal_mult_lt_0_compat. + rewrite <- CReal_opp_0. apply CReal_opp_gt_lt_contravar, c. + rewrite <- CReal_opp_0. apply CReal_opp_gt_lt_contravar, c0. ring. + + rewrite CReal_abs_left, CReal_abs_left, CReal_abs_right. ring. + apply CRealLt_asym, c0. apply CRealLt_asym, c. + rewrite <- (CReal_mult_0_l y). + apply CReal_mult_le_compat_r. + apply CRealLt_asym, c0. apply CRealLt_asym, c. + + rewrite CReal_abs_left, CReal_abs_right, CReal_abs_left. ring. + apply CRealLt_asym, c0. apply CRealLt_asym, c. + rewrite <- (CReal_mult_0_r x). + apply CReal_mult_le_compat_l. + apply CRealLt_asym, c. apply CRealLt_asym, c0. + + rewrite CReal_abs_right, CReal_abs_right, CReal_abs_right. ring. + apply CRealLt_asym, c0. apply CRealLt_asym, c. + apply CRealLt_asym, CReal_mult_lt_0_compat; assumption. } + split. + - intro abs. + assert (0 < CReal_abs x * CReal_abs y). + { apply (CReal_le_lt_trans _ (CReal_abs (x*y))). + apply CReal_abs_pos. exact abs. } + pose proof (CReal_mult_pos_appart_zero _ _ H). + rewrite CReal_mult_comm in H. + apply CReal_mult_pos_appart_zero in H. + destruct H. 2: apply (CReal_abs_pos y c). + destruct H0. 2: apply (CReal_abs_pos x c0). + apply CReal_abs_appart_0 in c. + apply CReal_abs_appart_0 in c0. + rewrite (prep x y) in abs. + exact (CRealLt_asym _ _ abs abs). exact c0. exact c. + - intro abs. + assert (0 < CReal_abs (x * y)). + { apply (CReal_le_lt_trans _ (CReal_abs x * CReal_abs y)). + rewrite <- (CReal_mult_0_l (CReal_abs y)). + apply CReal_mult_le_compat_r. + apply CReal_abs_pos. apply CReal_abs_pos. exact abs. } + apply CReal_abs_appart_0 in H. destruct H. + + apply CReal_opp_gt_lt_contravar in c. + rewrite CReal_opp_0, CReal_opp_mult_distr_l in c. + pose proof (CReal_mult_pos_appart_zero _ _ c). + rewrite CReal_mult_comm in c. + apply CReal_mult_pos_appart_zero in c. + rewrite (prep x y) in abs. + exact (CRealLt_asym _ _ abs abs). + destruct H. left. apply CReal_opp_gt_lt_contravar in c0. + rewrite CReal_opp_involutive, CReal_opp_0 in c0. exact c0. + right. apply CReal_opp_gt_lt_contravar in c0. + rewrite CReal_opp_involutive, CReal_opp_0 in c0. exact c0. + destruct c. right. exact c. left. exact c. + + pose proof (CReal_mult_pos_appart_zero _ _ c). + rewrite CReal_mult_comm in c. + apply CReal_mult_pos_appart_zero in c. + rewrite (prep x y) in abs. + exact (CRealLt_asym _ _ abs abs). + destruct H. right. exact c0. left. exact c0. + destruct c. right. exact c. left. exact c. +Qed. + +Lemma CReal_abs_def2 : forall x a:CReal, + CReal_abs x <= a -> (x <= a) /\ (- a <= x). +Proof. + split. + - exact (CReal_le_trans _ _ _ (CReal_le_abs _) H). + - rewrite <- (CReal_opp_involutive x). + apply CReal_opp_ge_le_contravar. + rewrite <- CReal_abs_opp in H. + exact (CReal_le_trans _ _ _ (CReal_le_abs _) H). +Qed. + + +(* Min and max *) + +Definition CReal_min (x y : CReal) : CReal + := (x + y - CReal_abs (y - x)) * inject_Q (1#2). + +Definition CReal_max (x y : CReal) : CReal + := (x + y + CReal_abs (y - x)) * inject_Q (1#2). + +Add Parametric Morphism : CReal_min + with signature CRealEq ==> CRealEq ==> CRealEq + as CReal_min_morph. +Proof. + intros. unfold CReal_min. + rewrite H, H0. reflexivity. +Qed. + +Add Parametric Morphism : CReal_max + with signature CRealEq ==> CRealEq ==> CRealEq + as CReal_max_morph. +Proof. + intros. unfold CReal_max. + rewrite H, H0. reflexivity. +Qed. + +Lemma CReal_double : forall x:CReal, 2 * x == x + x. +Proof. + intro x. rewrite (inject_Q_plus 1 1). ring. +Qed. + +Lemma CReal_max_lub : forall x y z:CReal, + x <= z -> y <= z -> CReal_max x y <= z. +Proof. + intros. unfold CReal_max. + apply (CReal_mult_le_reg_r 2). apply inject_Q_lt; reflexivity. + rewrite CReal_mult_assoc, <- inject_Q_mult. + setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. + rewrite CReal_mult_1_r. + apply (CReal_plus_le_reg_l (-x-y)). ring_simplify. + apply CReal_abs_le. split. + - unfold CReal_minus. repeat rewrite CReal_opp_plus_distr. + do 2 rewrite CReal_opp_involutive. + rewrite (CReal_plus_comm x), CReal_plus_assoc. apply CReal_plus_le_compat_l. + apply (CReal_plus_le_reg_l (-x)). + rewrite <- CReal_plus_assoc, CReal_plus_opp_l, CReal_plus_0_l. + rewrite CReal_mult_comm, CReal_double. rewrite CReal_opp_plus_distr. + apply CReal_plus_le_compat; apply CReal_opp_ge_le_contravar; assumption. + - unfold CReal_minus. + rewrite (CReal_plus_comm y), CReal_plus_assoc. apply CReal_plus_le_compat_l. + apply (CReal_plus_le_reg_l y). + rewrite <- CReal_plus_assoc, CReal_plus_opp_r, CReal_plus_0_l. + rewrite CReal_mult_comm, CReal_double. + apply CReal_plus_le_compat; assumption. +Qed. + +Lemma CReal_min_glb : forall x y z:CReal, + z <= x -> z <= y -> z <= CReal_min x y. +Proof. + intros. unfold CReal_min. + apply (CReal_mult_le_reg_r 2). apply inject_Q_lt; reflexivity. + rewrite CReal_mult_assoc, <- inject_Q_mult. + setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. + rewrite CReal_mult_1_r. + apply (CReal_plus_le_reg_l (CReal_abs(y-x) - (z*2))). ring_simplify. + apply CReal_abs_le. split. + - unfold CReal_minus. repeat rewrite CReal_opp_plus_distr. + rewrite CReal_opp_mult_distr_l, CReal_opp_involutive. + rewrite (CReal_plus_comm (z*2)), (CReal_plus_comm y), CReal_plus_assoc. + apply CReal_plus_le_compat_l, (CReal_plus_le_reg_r y). + rewrite CReal_plus_assoc, CReal_plus_opp_l, CReal_plus_0_r. + rewrite CReal_mult_comm, CReal_double. + apply CReal_plus_le_compat; assumption. + - unfold CReal_minus. + rewrite (CReal_plus_comm y). apply CReal_plus_le_compat. + 2: apply CRealLe_refl. + apply (CReal_plus_le_reg_r (-x)). + rewrite CReal_plus_assoc, CReal_plus_opp_r, CReal_plus_0_r. + rewrite CReal_mult_comm, CReal_double. + apply CReal_plus_le_compat; apply CReal_opp_ge_le_contravar; assumption. +Qed. + +Lemma CReal_max_l : forall x y : CReal, x <= CReal_max x y. +Proof. + intros. unfold CReal_max. + apply (CReal_mult_le_reg_r 2). apply inject_Q_lt; reflexivity. + rewrite CReal_mult_assoc, <- inject_Q_mult. + setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. + rewrite CReal_mult_1_r. + rewrite CReal_mult_comm, CReal_double. + rewrite CReal_plus_assoc. apply CReal_plus_le_compat_l. + apply (CReal_plus_le_reg_l (-y)). + rewrite <- CReal_plus_assoc, CReal_plus_opp_l, CReal_plus_0_l. + rewrite CReal_abs_minus_sym, CReal_plus_comm. + apply CReal_le_abs. +Qed. + +Lemma CReal_max_r : forall x y : CReal, y <= CReal_max x y. +Proof. + intros. unfold CReal_max. + apply (CReal_mult_le_reg_r 2). apply inject_Q_lt; reflexivity. + rewrite CReal_mult_assoc, <- inject_Q_mult. + setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. + rewrite CReal_mult_1_r. + rewrite CReal_mult_comm, CReal_double. + rewrite (CReal_plus_comm x). + rewrite CReal_plus_assoc. apply CReal_plus_le_compat_l. + apply (CReal_plus_le_reg_l (-x)). + rewrite <- CReal_plus_assoc, CReal_plus_opp_l, CReal_plus_0_l. + rewrite CReal_plus_comm. apply CReal_le_abs. +Qed. + +Lemma CReal_min_l : forall x y : CReal, CReal_min x y <= x. +Proof. + intros. unfold CReal_min. + apply (CReal_mult_le_reg_r 2). apply inject_Q_lt; reflexivity. + rewrite CReal_mult_assoc, <- inject_Q_mult. + setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. + rewrite CReal_mult_1_r. + rewrite CReal_mult_comm, CReal_double. + unfold CReal_minus. + rewrite CReal_plus_assoc. apply CReal_plus_le_compat_l. + apply (CReal_plus_le_reg_l (CReal_abs (y + - x)+ -x)). ring_simplify. + rewrite CReal_plus_comm. apply CReal_le_abs. +Qed. + +Lemma CReal_min_r : forall x y : CReal, CReal_min x y <= y. +Proof. + intros. unfold CReal_min. + apply (CReal_mult_le_reg_r 2). apply inject_Q_lt; reflexivity. + rewrite CReal_mult_assoc, <- inject_Q_mult. + setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. + rewrite CReal_mult_1_r. + rewrite CReal_mult_comm, CReal_double. + unfold CReal_minus. rewrite (CReal_plus_comm x). + rewrite CReal_plus_assoc. apply CReal_plus_le_compat_l. + apply (CReal_plus_le_reg_l (CReal_abs (y + - x)+ -y)). ring_simplify. + fold (y-x). rewrite CReal_abs_minus_sym. + rewrite CReal_plus_comm. apply CReal_le_abs. +Qed. + +Lemma CReal_min_left : forall x y : CReal, + x <= y -> CReal_min x y == x. +Proof. + intros. unfold CReal_min. + apply (CReal_mult_eq_reg_r 2). 2: right; apply inject_Q_lt; reflexivity. + rewrite CReal_mult_assoc, <- inject_Q_mult. + setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. + rewrite CReal_mult_1_r. + rewrite CReal_mult_comm, CReal_double. + rewrite CReal_abs_right. ring. + rewrite <- (CReal_plus_opp_r x). apply CReal_plus_le_compat. + exact H. apply CRealLe_refl. +Qed. + +Lemma CReal_min_right : forall x y : CReal, + y <= x -> CReal_min x y == y. +Proof. + intros. unfold CReal_min. + apply (CReal_mult_eq_reg_r 2). 2: right; apply inject_Q_lt; reflexivity. + rewrite CReal_mult_assoc, <- inject_Q_mult. + setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. + rewrite CReal_mult_1_r. + rewrite CReal_mult_comm, CReal_double. + rewrite CReal_abs_left. ring. + rewrite <- (CReal_plus_opp_r x). apply CReal_plus_le_compat. + exact H. apply CRealLe_refl. +Qed. + +Lemma CReal_max_left : forall x y : CReal, + y <= x -> CReal_max x y == x. +Proof. + intros. unfold CReal_max. + apply (CReal_mult_eq_reg_r 2). 2: right; apply inject_Q_lt; reflexivity. + rewrite CReal_mult_assoc, <- inject_Q_mult. + setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. + rewrite CReal_mult_1_r. + rewrite CReal_mult_comm, CReal_double. + rewrite CReal_abs_left. ring. + rewrite <- (CReal_plus_opp_r x). apply CReal_plus_le_compat. + exact H. apply CRealLe_refl. +Qed. + +Lemma CReal_max_right : forall x y : CReal, + x <= y -> CReal_max x y == y. +Proof. + intros. unfold CReal_max. + apply (CReal_mult_eq_reg_r 2). 2: right; apply inject_Q_lt; reflexivity. + rewrite CReal_mult_assoc, <- inject_Q_mult. + setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. + rewrite CReal_mult_1_r. + rewrite CReal_mult_comm, CReal_double. + rewrite CReal_abs_right. ring. + rewrite <- (CReal_plus_opp_r x). apply CReal_plus_le_compat. + exact H. apply CRealLe_refl. +Qed. + +Lemma CReal_min_lt_r : forall x y : CReal, + CReal_min x y < y -> CReal_min x y == x. +Proof. + intros. unfold CReal_min. unfold CReal_min in H. + apply (CReal_mult_eq_reg_r 2). 2: right; apply inject_Q_lt; reflexivity. + rewrite CReal_mult_assoc, <- inject_Q_mult. + setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. + rewrite CReal_mult_1_r. + rewrite CReal_mult_comm, CReal_double. + rewrite CReal_abs_right. ring. + apply (CReal_mult_lt_compat_r 2) in H. 2: apply inject_Q_lt; reflexivity. + rewrite CReal_mult_assoc, <- inject_Q_mult in H. + setoid_replace ((1 # 2) * 2)%Q with 1%Q in H. 2: reflexivity. + rewrite CReal_mult_1_r in H. + rewrite CReal_mult_comm, CReal_double in H. + intro abs. rewrite CReal_abs_left in H. + unfold CReal_minus in H. + rewrite CReal_opp_involutive, CReal_plus_comm in H. + rewrite CReal_plus_assoc, <- (CReal_plus_assoc (-x)), CReal_plus_opp_l in H. + rewrite CReal_plus_0_l in H. exact (CRealLt_asym _ _ H H). + apply CRealLt_asym, abs. +Qed. + +Lemma posPartAbsMax : forall x : CReal, + CReal_max 0 x == (x + CReal_abs x) * (inject_Q (1#2)). +Proof. + split. + - intro abs. apply (CReal_mult_lt_compat_r 2) in abs. + 2: apply (inject_Q_lt 0 2); reflexivity. + rewrite CReal_mult_assoc, <- (inject_Q_mult) in abs. + setoid_replace ((1 # 2) * 2)%Q with 1%Q in abs. 2: reflexivity. + rewrite CReal_mult_1_r in abs. + apply (CReal_plus_lt_compat_l (-x)) in abs. + rewrite <- CReal_plus_assoc, CReal_plus_opp_l, CReal_plus_0_l in abs. + apply CReal_abs_le in abs. exact abs. split. + + rewrite CReal_opp_plus_distr, CReal_opp_involutive. + apply (CReal_le_trans _ (x + 0)). 2: rewrite CReal_plus_0_r; apply CRealLe_refl. + apply CReal_plus_le_compat_l. apply (CReal_le_trans _ (2 * 0)). + rewrite CReal_opp_mult_distr_l, <- (CReal_mult_comm 2). apply CReal_mult_le_compat_l_half. + apply inject_Q_lt. reflexivity. + apply (CReal_plus_le_reg_l (CReal_max 0 x)). rewrite CReal_plus_opp_r, CReal_plus_0_r. + apply CReal_max_l. rewrite CReal_mult_0_r. apply CRealLe_refl. + + apply (CReal_plus_le_reg_l x). + rewrite <- CReal_plus_assoc, CReal_plus_opp_r, CReal_plus_0_l. + rewrite (inject_Q_plus 1 1), CReal_mult_plus_distr_l, CReal_mult_1_r. + apply CReal_plus_le_compat; apply CReal_max_r. + - apply CReal_max_lub. rewrite <- (CReal_mult_0_l (inject_Q (1#2))). + do 2 rewrite <- (CReal_mult_comm (inject_Q (1#2))). + apply CReal_mult_le_compat_l_half. + apply inject_Q_lt; reflexivity. + rewrite <- (CReal_plus_opp_r x). apply CReal_plus_le_compat_l. + rewrite <- CReal_abs_opp. apply CReal_le_abs. + intros abs. + apply (CReal_mult_lt_compat_r 2) in abs. 2: apply inject_Q_lt; reflexivity. + rewrite CReal_mult_assoc, <- inject_Q_mult in abs. + setoid_replace ((1 # 2) * 2)%Q with 1%Q in abs. 2: reflexivity. + rewrite CReal_mult_1_r, (inject_Q_plus 1 1), CReal_mult_plus_distr_l, CReal_mult_1_r in abs. + apply CReal_plus_lt_reg_l in abs. + exact (CReal_le_abs x abs). +Qed. + +Lemma negPartAbsMin : forall x : CReal, + CReal_min 0 x == (x - CReal_abs x) * (inject_Q (1#2)). +Proof. + split. + - intro abs. apply (CReal_mult_lt_compat_r 2) in abs. + 2: apply (inject_Q_lt 0 2); reflexivity. + rewrite CReal_mult_assoc, <- (inject_Q_mult) in abs. + setoid_replace ((1 # 2) * 2)%Q with 1%Q in abs. 2: reflexivity. + rewrite CReal_mult_1_r in abs. + apply (CReal_plus_lt_compat_r (CReal_abs x)) in abs. + unfold CReal_minus in abs. + rewrite CReal_plus_assoc, CReal_plus_opp_l, CReal_plus_0_r in abs. + apply (CReal_plus_lt_compat_l (-(CReal_min 0 x * 2))) in abs. + rewrite <- CReal_plus_assoc, CReal_plus_opp_l, CReal_plus_0_l in abs. + apply CReal_abs_lt in abs. destruct abs. + apply (CReal_plus_lt_compat_l (CReal_min 0 x * 2)) in c0. + rewrite <- CReal_plus_assoc, CReal_plus_opp_r, CReal_plus_0_l in c0. + apply (CReal_plus_lt_compat_r x) in c0. + rewrite CReal_plus_assoc, CReal_plus_opp_l, CReal_plus_0_r in c0. + rewrite <- CReal_double, CReal_mult_comm in c0. apply CReal_mult_lt_reg_l in c0. + apply CReal_min_lt_r in c0. + rewrite c0, CReal_mult_0_l, CReal_opp_0, CReal_plus_0_l in c. + exact (CRealLt_asym _ _ c c). apply inject_Q_lt; reflexivity. + - intro abs. + assert ((x - CReal_abs x) * inject_Q (1 # 2) < 0 * inject_Q (1 # 2)). + { rewrite CReal_mult_0_l. + apply (CReal_lt_le_trans _ _ _ abs). apply CReal_min_l. } + apply CReal_mult_lt_reg_r in H. + 2: apply inject_Q_lt; reflexivity. + rewrite <- (CReal_plus_opp_r (CReal_abs x)) in H. + apply CReal_plus_lt_reg_r, CReal_abs_gt in H. + rewrite CReal_min_right, <- CReal_abs_opp, CReal_abs_right in abs. + unfold CReal_minus in abs. + rewrite CReal_opp_involutive, <- CReal_double, CReal_mult_comm in abs. + rewrite <- CReal_mult_assoc, <- inject_Q_mult in abs. + setoid_replace ((1 # 2) * 2)%Q with 1%Q in abs. + rewrite CReal_mult_1_l in abs. exact (CRealLt_asym _ _ abs abs). + reflexivity. rewrite <- CReal_opp_0. + apply CReal_opp_ge_le_contravar, CRealLt_asym, H. + apply CRealLt_asym, H. +Qed. + +Lemma CReal_min_sym : forall (x y : CReal), + CReal_min x y == CReal_min y x. +Proof. + intros. unfold CReal_min. + rewrite CReal_abs_minus_sym. ring. +Qed. + +Lemma CReal_max_sym : forall (x y : CReal), + CReal_max x y == CReal_max y x. +Proof. + intros. unfold CReal_max. + rewrite CReal_abs_minus_sym. ring. +Qed. + +Lemma CReal_min_mult : + forall (p q r:CReal), 0 <= r -> CReal_min (r * p) (r * q) == r * CReal_min p q. +Proof. + intros p q r H. unfold CReal_min. + setoid_replace (r * q - r * p) with (r * (q - p)). + 2: ring. rewrite CReal_abs_mult. + rewrite (CReal_abs_right r). ring. exact H. +Qed. + +Lemma CReal_min_plus : forall (x y z : CReal), + x + CReal_min y z == CReal_min (x + y) (x + z). +Proof. + intros. unfold CReal_min. + setoid_replace (x + z - (x + y)) with (z-y). + 2: ring. + apply (CReal_mult_eq_reg_r 2). 2: right; apply inject_Q_lt; reflexivity. + rewrite CReal_mult_plus_distr_r. + rewrite CReal_mult_assoc, <- inject_Q_mult. + setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. + rewrite CReal_mult_1_r. + rewrite CReal_mult_assoc, <- inject_Q_mult. + setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. + rewrite CReal_mult_1_r. + rewrite CReal_mult_comm, CReal_double. ring. +Qed. + +Lemma CReal_max_plus : forall (x y z : CReal), + x + CReal_max y z == CReal_max (x + y) (x + z). +Proof. + intros. unfold CReal_max. + setoid_replace (x + z - (x + y)) with (z-y). + 2: ring. + apply (CReal_mult_eq_reg_r 2). 2: right; apply inject_Q_lt; reflexivity. + rewrite CReal_mult_plus_distr_r. + rewrite CReal_mult_assoc, <- inject_Q_mult. + setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. + rewrite CReal_mult_1_r. + rewrite CReal_mult_assoc, <- inject_Q_mult. + setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. + rewrite CReal_mult_1_r. + rewrite CReal_mult_comm, CReal_double. ring. +Qed. + +Lemma CReal_min_lt : forall x y z : CReal, + z < x -> z < y -> z < CReal_min x y. +Proof. + intros. unfold CReal_min. + apply (CReal_mult_lt_reg_r 2). apply inject_Q_lt; reflexivity. + rewrite CReal_mult_assoc, <- inject_Q_mult. + setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. + rewrite CReal_mult_1_r. + apply (CReal_plus_lt_reg_l (CReal_abs (y - x) - (z*2))). + ring_simplify. apply Rabs_def1. + - unfold CReal_minus. rewrite <- (CReal_plus_comm y). + apply CReal_plus_lt_compat_l. + apply (CReal_plus_lt_reg_r (-x)). + rewrite CReal_plus_assoc, CReal_plus_opp_r, CReal_plus_0_r. + rewrite <- CReal_double, CReal_mult_comm. apply CReal_mult_lt_compat_r. + apply inject_Q_lt; reflexivity. + apply CReal_opp_gt_lt_contravar, H. + - unfold CReal_minus. rewrite CReal_opp_plus_distr, CReal_opp_involutive. + rewrite CReal_plus_comm, (CReal_plus_comm (-z*2)), CReal_plus_assoc. + apply CReal_plus_lt_compat_l. + apply (CReal_plus_lt_reg_r (-y)). + rewrite CReal_plus_assoc, CReal_plus_opp_r, CReal_plus_0_r. + rewrite <- CReal_double, CReal_mult_comm. apply CReal_mult_lt_compat_r. + apply inject_Q_lt; reflexivity. + apply CReal_opp_gt_lt_contravar, H0. +Qed. + +Lemma CReal_max_assoc : forall a b c : CReal, + CReal_max a (CReal_max b c) == CReal_max (CReal_max a b) c. +Proof. + split. + - apply CReal_max_lub. + + apply CReal_max_lub. apply CReal_max_l. + apply (CReal_le_trans _ (CReal_max b c)). + apply CReal_max_l. apply CReal_max_r. + + apply (CReal_le_trans _ (CReal_max b c)). + apply CReal_max_r. apply CReal_max_r. + - apply CReal_max_lub. + + apply (CReal_le_trans _ (CReal_max a b)). + apply CReal_max_l. apply CReal_max_l. + + apply CReal_max_lub. + apply (CReal_le_trans _ (CReal_max a b)). + apply CReal_max_r. apply CReal_max_l. apply CReal_max_r. +Qed. + +Lemma CReal_min_max_mult_neg : + forall (p q r:CReal), r <= 0 -> CReal_min (r * p) (r * q) == r * CReal_max p q. +Proof. + intros p q r H. unfold CReal_min, CReal_max. + setoid_replace (r * q - r * p) with (r * (q - p)). + 2: ring. rewrite CReal_abs_mult. + rewrite (CReal_abs_left r). ring. exact H. +Qed. + +Lemma CReal_min_assoc : forall a b c : CReal, + CReal_min a (CReal_min b c) == CReal_min (CReal_min a b) c. +Proof. + split. + - apply CReal_min_glb. + + apply (CReal_le_trans _ (CReal_min a b)). + apply CReal_min_l. apply CReal_min_l. + + apply CReal_min_glb. + apply (CReal_le_trans _ (CReal_min a b)). + apply CReal_min_l. apply CReal_min_r. apply CReal_min_r. + - apply CReal_min_glb. + + apply CReal_min_glb. apply CReal_min_l. + apply (CReal_le_trans _ (CReal_min b c)). + apply CReal_min_r. apply CReal_min_l. + + apply (CReal_le_trans _ (CReal_min b c)). + apply CReal_min_r. apply CReal_min_r. +Qed. + +Lemma CReal_max_lub_lt : forall x y z : CReal, + x < z -> y < z -> CReal_max x y < z. +Proof. + intros. unfold CReal_max. + apply (CReal_mult_lt_reg_r 2). apply inject_Q_lt; reflexivity. + rewrite CReal_mult_assoc, <- inject_Q_mult. + setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. + rewrite CReal_mult_1_r. + apply (CReal_plus_lt_reg_l (-x -y)). ring_simplify. + apply Rabs_def1. + - unfold CReal_minus. rewrite (CReal_plus_comm y), CReal_plus_assoc. + apply CReal_plus_lt_compat_l. + apply (CReal_plus_lt_reg_l y). + rewrite <- CReal_plus_assoc, CReal_plus_opp_r, CReal_plus_0_l. + rewrite <- CReal_double, CReal_mult_comm. apply CReal_mult_lt_compat_r. + apply inject_Q_lt; reflexivity. exact H0. + - unfold CReal_minus. rewrite CReal_opp_plus_distr, CReal_opp_involutive. + rewrite (CReal_plus_comm (-x)), CReal_plus_assoc. + apply CReal_plus_lt_compat_l. + apply (CReal_plus_lt_reg_l x). + rewrite <- CReal_plus_assoc, CReal_plus_opp_r, CReal_plus_0_l. + rewrite <- CReal_double, CReal_mult_comm. apply CReal_mult_lt_compat_r. + apply inject_Q_lt; reflexivity. + apply H. +Qed. + +Lemma CReal_max_contract : forall x y a : CReal, + CReal_abs (CReal_max x a - CReal_max y a) + <= CReal_abs (x - y). +Proof. + intros. unfold CReal_max. + rewrite (CReal_abs_morph + _ ((x - y + (CReal_abs (a - x) - CReal_abs (a - y))) * inject_Q (1 # 2))). + 2: ring. + rewrite CReal_abs_mult, (CReal_abs_right (inject_Q (1 # 2))). + 2: apply inject_Q_le; discriminate. + apply (CReal_le_trans + _ ((CReal_abs (x - y) * 1 + CReal_abs (x-y) * 1) + * inject_Q (1 # 2))). + apply CReal_mult_le_compat_r. apply inject_Q_le. discriminate. + apply (CReal_le_trans _ (CReal_abs (x - y) + CReal_abs (CReal_abs (a - x) - CReal_abs (a - y)))). + apply CReal_abs_triang. rewrite CReal_mult_1_r. apply CReal_plus_le_compat_l. + rewrite (CReal_abs_minus_sym x y). + rewrite (CReal_abs_morph (y-x) ((a-x)-(a-y))). + apply CReal_abs_triang_inv2. + unfold CReal_minus. rewrite (CReal_plus_comm (a + - x)). + rewrite <- CReal_plus_assoc. apply CReal_plus_morph. 2: reflexivity. + rewrite CReal_plus_comm, CReal_opp_plus_distr, <- CReal_plus_assoc. + rewrite CReal_plus_opp_r, CReal_opp_involutive, CReal_plus_0_l. + reflexivity. + rewrite <- CReal_mult_plus_distr_l, <- inject_Q_plus. + rewrite CReal_mult_assoc, <- inject_Q_mult. + setoid_replace ((1 + 1) * (1 # 2))%Q with 1%Q. 2: reflexivity. + rewrite CReal_mult_1_r. apply CRealLe_refl. +Qed. + +Lemma CReal_min_contract : forall x y a : CReal, + CReal_abs (CReal_min x a - CReal_min y a) + <= CReal_abs (x - y). +Proof. + intros. unfold CReal_min. + rewrite (CReal_abs_morph + _ ((x - y + (CReal_abs (a - y) - CReal_abs (a - x))) * inject_Q (1 # 2))). + 2: ring. + rewrite CReal_abs_mult, (CReal_abs_right (inject_Q (1 # 2))). + 2: apply inject_Q_le; discriminate. + apply (CReal_le_trans + _ ((CReal_abs (x - y) * 1 + CReal_abs (x-y) * 1) + * inject_Q (1 # 2))). + apply CReal_mult_le_compat_r. apply inject_Q_le. discriminate. + apply (CReal_le_trans _ (CReal_abs (x - y) + CReal_abs (CReal_abs (a - y) - CReal_abs (a - x)))). + apply CReal_abs_triang. rewrite CReal_mult_1_r. apply CReal_plus_le_compat_l. + rewrite (CReal_abs_morph (x-y) ((a-y)-(a-x))). + apply CReal_abs_triang_inv2. + unfold CReal_minus. rewrite (CReal_plus_comm (a + - y)). + rewrite <- CReal_plus_assoc. apply CReal_plus_morph. 2: reflexivity. + rewrite CReal_plus_comm, CReal_opp_plus_distr, <- CReal_plus_assoc. + rewrite CReal_plus_opp_r, CReal_opp_involutive, CReal_plus_0_l. + reflexivity. + rewrite <- CReal_mult_plus_distr_l, <- inject_Q_plus. + rewrite CReal_mult_assoc, <- inject_Q_mult. + setoid_replace ((1 + 1) * (1 # 2))%Q with 1%Q. 2: reflexivity. + rewrite CReal_mult_1_r. apply CRealLe_refl. +Qed. diff --git a/theories/Reals/ConstructiveCauchyReals.v b/theories/Reals/Cauchy/ConstructiveCauchyReals.v index 62e42a7ef3..167f8d41c9 100644 --- a/theories/Reals/ConstructiveCauchyReals.v +++ b/theories/Reals/Cauchy/ConstructiveCauchyReals.v @@ -275,12 +275,6 @@ Proof. pose proof (Pos2Nat.is_pos n). rewrite abs in H. inversion H. Qed. -(* Alias the quotient order equality *) -Definition CRealEq (x y : CReal) : Prop - := (CRealLt x y -> False) /\ (CRealLt y x -> False). - -Infix "==" := CRealEq : CReal_scope. - (* Alias the large order *) Definition CRealLe (x y : CReal) : Prop := CRealLt y x -> False. @@ -295,6 +289,12 @@ Notation "x <= y < z" := (prod (x <= y) (y < z)) : CReal_scope. Notation "x < y < z" := (prod (x < y) (y < z)) : CReal_scope. Notation "x < y <= z" := (prod (x < y) (y <= z)) : CReal_scope. +(* Alias the quotient order equality *) +Definition CRealEq (x y : CReal) : Prop + := (CRealLe y x) /\ (CRealLe x y). + +Infix "==" := CRealEq : CReal_scope. + Lemma CRealLe_not_lt : forall x y : CReal, (forall n:positive, Qle (proj1_sig x (Pos.to_nat n) - proj1_sig y (Pos.to_nat n)) (2 # n)) @@ -322,13 +322,16 @@ Proof. setoid_replace (- (proj1_sig x (Pos.to_nat n) - proj1_sig y (Pos.to_nat n))) with (proj1_sig y (Pos.to_nat n) - proj1_sig x (Pos.to_nat n)). apply H2. assumption. ring. - - intros. split. apply CRealLe_not_lt. intro n. specialize (H n). - rewrite Qabs_Qminus in H. - apply (Qle_trans _ (Qabs (proj1_sig y (Pos.to_nat n) - proj1_sig x (Pos.to_nat n)))). - apply Qle_Qabs. apply H. - apply CRealLe_not_lt. intro n. specialize (H n). - apply (Qle_trans _ (Qabs (proj1_sig x (Pos.to_nat n) - proj1_sig y (Pos.to_nat n)))). - apply Qle_Qabs. apply H. + - intros. split. + + apply CRealLe_not_lt. intro n. specialize (H n). + rewrite Qabs_Qminus in H. + apply (Qle_trans _ (Qabs (proj1_sig y (Pos.to_nat n) + - proj1_sig x (Pos.to_nat n)))). + apply Qle_Qabs. apply H. + + apply CRealLe_not_lt. intro n. specialize (H n). + apply (Qle_trans _ (Qabs (proj1_sig x (Pos.to_nat n) + - proj1_sig y (Pos.to_nat n)))). + apply Qle_Qabs. apply H. Qed. (* The equality on Cauchy reals is just QSeqEquiv, diff --git a/theories/Reals/ConstructiveCauchyRealsMult.v b/theories/Reals/Cauchy/ConstructiveCauchyRealsMult.v index 7530a8f1ef..fa24bd988e 100644 --- a/theories/Reals/ConstructiveCauchyRealsMult.v +++ b/theories/Reals/Cauchy/ConstructiveCauchyRealsMult.v @@ -15,7 +15,7 @@ Require Import QArith. Require Import Qabs. Require Import Qround. Require Import Logic.ConstructiveEpsilon. -Require Export Reals.ConstructiveCauchyReals. +Require Export ConstructiveCauchyReals. Require CMorphisms. Local Open Scope CReal_scope. @@ -1413,3 +1413,91 @@ Proof. destruct (QCauchySeq_bounded (fun _ : nat => r) Pos.to_nat (ConstCauchy r)). simpl in maj. ring_simplify in maj. discriminate maj. Qed. + +Definition Rup_nat (x : CReal) + : { n : nat & x < inject_Q (Z.of_nat n #1) }. +Proof. + intros. destruct (CRealArchimedean x) as [p maj]. + destruct p. + - exists O. apply maj. + - exists (Pos.to_nat p). rewrite positive_nat_Z. apply maj. + - exists O. apply (CReal_lt_trans _ (inject_Q (Z.neg p # 1))). + apply maj. apply inject_Q_lt. reflexivity. +Qed. + +Lemma CReal_mult_le_0_compat : forall (a b : CReal), + 0 <= a -> 0 <= b -> 0 <= a * b. +Proof. + (* Limit of (a + 1/n)*b when n -> infty. *) + intros. intro abs. + assert (0 < -(a*b)) as epsPos. + { rewrite <- CReal_opp_0. apply CReal_opp_gt_lt_contravar. exact abs. } + destruct (Rup_nat (b * (/ (-(a*b))) (inr epsPos))) + as [n maj]. + destruct n as [|n]. + - apply (CReal_mult_lt_compat_r (-(a*b))) in maj. + rewrite CReal_mult_0_l, CReal_mult_assoc, CReal_inv_l, CReal_mult_1_r in maj. + contradiction. exact epsPos. + - (* n > 0 *) + assert (0 < inject_Q (Z.of_nat (S n) #1)) as nPos. + { apply inject_Q_lt. unfold Qlt, Qnum, Qden. + do 2 rewrite Z.mul_1_r. apply Z2Nat.inj_lt. discriminate. + apply Zle_0_nat. rewrite Nat2Z.id. apply le_n_S, le_0_n. } + assert (b * (/ inject_Q (Z.of_nat (S n) #1)) (inr nPos) < -(a*b)). + { apply (CReal_mult_lt_reg_r (inject_Q (Z.of_nat (S n) #1))). apply nPos. + rewrite CReal_mult_assoc, CReal_inv_l, CReal_mult_1_r. + apply (CReal_mult_lt_compat_r (-(a*b))) in maj. + rewrite CReal_mult_assoc, CReal_inv_l, CReal_mult_1_r in maj. + rewrite CReal_mult_comm. apply maj. apply epsPos. } + pose proof (CReal_mult_le_compat_l_half + (a + (/ inject_Q (Z.of_nat (S n) #1)) (inr nPos)) 0 b). + assert (0 + 0 < a + (/ inject_Q (Z.of_nat (S n) #1)) (inr nPos)). + { apply CReal_plus_le_lt_compat. apply H. apply CReal_inv_0_lt_compat. apply nPos. } + rewrite CReal_plus_0_l in H3. specialize (H2 H3 H0). + clear H3. rewrite CReal_mult_0_r in H2. + apply H2. clear H2. rewrite CReal_mult_plus_distr_r. + apply (CReal_plus_lt_compat_l (a*b)) in H1. + rewrite CReal_plus_opp_r in H1. + rewrite (CReal_mult_comm ((/ inject_Q (Z.of_nat (S n) #1)) (inr nPos))). + apply H1. +Qed. + +Lemma CReal_mult_le_compat_l : forall (r r1 r2:CReal), + 0 <= r -> r1 <= r2 -> r * r1 <= r * r2. +Proof. + intros. apply (CReal_plus_le_reg_r (-(r*r1))). + rewrite CReal_plus_opp_r, CReal_opp_mult_distr_r. + rewrite <- CReal_mult_plus_distr_l. + apply CReal_mult_le_0_compat. exact H. + apply (CReal_plus_le_reg_r r1). + rewrite CReal_plus_0_l, CReal_plus_assoc, CReal_plus_opp_l, CReal_plus_0_r. + exact H0. +Qed. + +Lemma CReal_mult_le_compat_r : forall (r r1 r2:CReal), + 0 <= r -> r1 <= r2 -> r1 * r <= r2 * r. +Proof. + intros. apply (CReal_plus_le_reg_r (-(r1*r))). + rewrite CReal_plus_opp_r, CReal_opp_mult_distr_l. + rewrite <- CReal_mult_plus_distr_r. + apply CReal_mult_le_0_compat. 2: exact H. + apply (CReal_plus_le_reg_r r1). ring_simplify. exact H0. +Qed. + +Lemma CReal_mult_le_reg_l : + forall x y z : CReal, + 0 < x -> x * y <= x * z -> y <= z. +Proof. + intros. intro abs. + apply (CReal_mult_lt_compat_l x) in abs. contradiction. + exact H. +Qed. + +Lemma CReal_mult_le_reg_r : + forall x y z : CReal, + 0 < x -> y * x <= z * x -> y <= z. +Proof. + intros. intro abs. + apply (CReal_mult_lt_compat_r x) in abs. contradiction. + exact H. +Qed. diff --git a/theories/Reals/ConstructiveRcomplete.v b/theories/Reals/Cauchy/ConstructiveRcomplete.v index 7d743e464e..51fd0dd7f9 100644 --- a/theories/Reals/ConstructiveRcomplete.v +++ b/theories/Reals/Cauchy/ConstructiveRcomplete.v @@ -14,52 +14,76 @@ Require Import Qabs. Require Import ConstructiveReals. Require Import ConstructiveCauchyRealsMult. Require Import Logic.ConstructiveEpsilon. +Require Import ConstructiveCauchyAbs. Local Open Scope CReal_scope. -Definition absLe (a b : CReal) : Prop - := -b <= a <= b. +(* We use <= in sort Prop rather than < in sort Set, + it is equivalent for the definition of limits and it + extracts smaller programs. *) +Definition seq_cv (un : nat -> CReal) (l : CReal) : Set + := forall p : positive, + { n : nat | forall i:nat, le n i -> CReal_abs (un i - l) <= inject_Q (1#p) }. -Lemma CReal_absSmall : forall (x y : CReal) (n : positive), - (Qlt (2 # n) - (proj1_sig x (Pos.to_nat n) - Qabs (proj1_sig y (Pos.to_nat n)))) - -> absLe y x. +Definition Un_cauchy_mod (un : nat -> CReal) : Set + := forall p : positive, + { n : nat | forall i j:nat, le n i -> le n j + -> CReal_abs (un i - un j) <= inject_Q (1#p) }. + +Lemma seq_cv_proper : forall (un : nat -> CReal) (a b : CReal), + seq_cv un a + -> a == b + -> seq_cv un b. Proof. - intros x y n maj. split. - - apply CRealLt_asym. exists n. destruct x as [xn caux], y as [yn cauy]; simpl. - simpl in maj. unfold Qminus. rewrite Qopp_involutive. - rewrite Qplus_comm. - apply (Qlt_le_trans _ (xn (Pos.to_nat n) - Qabs (yn (Pos.to_nat n)))). - apply maj. apply Qplus_le_r. - rewrite <- (Qopp_involutive (yn (Pos.to_nat n))). - apply Qopp_le_compat. rewrite Qabs_opp. apply Qle_Qabs. - - apply CRealLt_asym. exists n. destruct x as [xn caux], y as [yn cauy]; simpl. - simpl in maj. - apply (Qlt_le_trans _ (xn (Pos.to_nat n) - Qabs (yn (Pos.to_nat n)))). - apply maj. apply Qplus_le_r. apply Qopp_le_compat. apply Qle_Qabs. + intros. intro p. specialize (H p) as [n H]. + exists n. intros. rewrite <- H0. apply H, H1. Qed. -(* We use absLe in sort Prop rather than Set, - to extract smaller programs. *) -Definition Un_cv_mod (un : nat -> CReal) (l : CReal) : Set - := forall p : positive, - { n : nat | forall i:nat, le n i -> absLe (un i - l) (inject_Q (1#p)) }. +Instance seq_cv_morph + : forall (un : nat -> CReal), CMorphisms.Proper + (CMorphisms.respectful CRealEq CRelationClasses.iffT) (seq_cv un). +Proof. + split. intros. apply (seq_cv_proper un x). exact H0. exact H. + intros. apply (seq_cv_proper un y). exact H0. symmetry. exact H. +Qed. -Lemma Un_cv_mod_eq : forall (v u : nat -> CReal) (s : CReal), - (forall n:nat, u n == v n) - -> Un_cv_mod u s - -> Un_cv_mod v s. +Lemma growing_transit : forall un : nat -> CReal, + (forall n:nat, un n <= un (S n)) + -> forall n p : nat, le n p -> un n <= un p. Proof. - intros v u s seq H1 p. specialize (H1 p) as [N H0]. - exists N. intros. split. - rewrite <- seq. apply H0. apply H. - rewrite <- seq. apply H0. apply H. + induction p. + - intros. inversion H0. apply CRealLe_refl. + - intros. apply Nat.le_succ_r in H0. destruct H0. + apply (CReal_le_trans _ (un p)). apply IHp, H0. apply H. + subst n. apply CRealLe_refl. +Qed. + +Lemma growing_infinite : forall un : nat -> nat, + (forall n:nat, lt (un n) (un (S n))) + -> forall n : nat, le n (un n). +Proof. + induction n. + - apply le_0_n. + - specialize (H n). unfold lt in H. + apply (le_trans _ (S (un n))). apply le_n_S, IHn. exact H. +Qed. + +Lemma Un_cv_growing : forall (un : nat -> CReal) (l : CReal), + (forall n:nat, un n <= un (S n)) + -> (forall n:nat, un n <= l) + -> (forall p : positive, { n : nat | l - un n <= inject_Q (1#p) }) + -> seq_cv un l. +Proof. + intros. intro p. + specialize (H1 p) as [n nmaj]. exists n. + intros. rewrite CReal_abs_minus_sym, CReal_abs_right. + apply (CReal_le_trans _ (l - un n)). apply CReal_plus_le_compat_l. + apply CReal_opp_ge_le_contravar. + exact (growing_transit _ H n i H1). exact nmaj. + rewrite <- (CReal_plus_opp_r (un i)). apply CReal_plus_le_compat. + apply H0. apply CRealLe_refl. Qed. -Definition Un_cauchy_mod (un : nat -> CReal) : Set - := forall p : positive, - { n : nat | forall i j:nat, le n i -> le n j - -> absLe (un i - un j) (inject_Q (1#p)) }. (* Sharpen the archimedean property : constructive versions of @@ -142,11 +166,32 @@ Proof. reflexivity. Qed. +Lemma Qabs_Rabs : forall q : Q, + inject_Q (Qabs q) == CReal_abs (inject_Q q). +Proof. + intro q. apply Qabs_case. + - intros. rewrite CReal_abs_right. reflexivity. + apply inject_Q_le, H. + - intros. rewrite CReal_abs_left, opp_inject_Q. reflexivity. + apply inject_Q_le, H. +Qed. + Definition Un_cauchy_Q (xn : nat -> Q) : Set := forall n : positive, { k : nat | forall p q : nat, le k p -> le k q - -> Qle (-(1#n)) (xn p - xn q) - /\ Qle (xn p - xn q) (1#n) }. + -> (Qabs (xn p - xn q) <= 1#n)%Q }. + +Lemma CReal_smaller_interval : forall a b c d : CReal, + a <= c -> c <= b + -> a <= d -> d <= b + -> CReal_abs (d - c) <= b-a. +Proof. + intros. apply CReal_abs_le. split. + - apply (CReal_plus_le_reg_l (b+c)). ring_simplify. + apply CReal_plus_le_compat; assumption. + - apply (CReal_plus_le_reg_l (a+c)). ring_simplify. + apply CReal_plus_le_compat; assumption. +Qed. Lemma Rdiag_cauchy_sequence : forall (xn : nat -> CReal), Un_cauchy_mod xn @@ -154,92 +199,103 @@ Lemma Rdiag_cauchy_sequence : forall (xn : nat -> CReal), Proof. intros xn H p. specialize (H (2 * p)%positive) as [k cv]. exists (max k (2 * Pos.to_nat p)). intros. - specialize (cv p0 q). destruct cv. - apply (le_trans _ (Init.Nat.max k (2 * Pos.to_nat p))). - apply Nat.le_max_l. apply H. - apply (le_trans _ (Init.Nat.max k (2 * Pos.to_nat p))). - apply Nat.le_max_l. apply H0. - split. + specialize (cv p0 q + (le_trans _ _ _ (Nat.le_max_l _ _) H) + (le_trans _ _ _ (Nat.le_max_l _ _) H0)). + destruct (RQ_limit (xn p0) p0) as [r rmaj]. + destruct (RQ_limit (xn q) q) as [s smaj]. + apply Qabs_Qle_condition. split. - apply le_inject_Q. unfold Qminus. apply (CReal_le_trans _ (xn p0 - (xn q + inject_Q (1 # 2 * p)))). + unfold CReal_minus. rewrite CReal_opp_plus_distr. rewrite <- CReal_plus_assoc. - apply (CReal_plus_le_reg_r (inject_Q (1 # 2 * p))). - rewrite CReal_plus_assoc. rewrite CReal_plus_opp_l. rewrite CReal_plus_0_r. + apply (CReal_plus_le_reg_r (xn q - xn p0 - inject_Q (-(1#p)))). + ring_simplify. unfold CReal_minus. do 2 rewrite <- opp_inject_Q. rewrite <- inject_Q_plus. - setoid_replace (- (1 # p) + (1 # 2 * p))%Q with (- (1 # 2 * p))%Q. - rewrite opp_inject_Q. exact H1. - rewrite Qplus_comm. + setoid_replace (- - (1 # p) + - (1 # 2 * p))%Q with (1 # 2 * p)%Q. + rewrite CReal_abs_minus_sym in cv. + exact (CReal_le_trans _ _ _ (CReal_le_abs _ ) cv). + rewrite Qopp_involutive. setoid_replace (1#p)%Q with (2 # 2 *p)%Q. rewrite Qinv_minus_distr. reflexivity. reflexivity. + rewrite inject_Q_plus. apply CReal_plus_le_compat. apply CRealLt_asym. - destruct (RQ_limit (xn p0) p0); simpl. apply p1. + destruct (RQ_limit (xn p0) p0); simpl. apply rmaj. apply CRealLt_asym. - destruct (RQ_limit (xn q) q); unfold proj1_sig. rewrite opp_inject_Q. apply CReal_opp_gt_lt_contravar. - apply (CReal_lt_le_trans _ (xn q + inject_Q (1 # Pos.of_nat q))). - apply p1. apply CReal_plus_le_compat_l. apply inject_Q_le. + destruct smaj. apply (CReal_lt_le_trans _ _ _ c0). + apply CReal_plus_le_compat_l. apply inject_Q_le. apply Z2Nat.inj_le. discriminate. discriminate. simpl. assert ((Pos.to_nat p~0 <= q)%nat). { apply (le_trans _ (Init.Nat.max k (2 * Pos.to_nat p))). 2: apply H0. replace (p~0)%positive with (2*p)%positive. 2: reflexivity. rewrite Pos2Nat.inj_mul. apply Nat.le_max_r. } - rewrite Nat2Pos.id. apply H3. intro abs. subst q. - inversion H3. pose proof (Pos2Nat.is_pos (p~0)). - rewrite H5 in H4. inversion H4. + rewrite Nat2Pos.id. apply H1. intro abs. subst q. + inversion H1. pose proof (Pos2Nat.is_pos (p~0)). + rewrite H3 in H2. inversion H2. - apply le_inject_Q. unfold Qminus. apply (CReal_le_trans _ (xn p0 + inject_Q (1 # 2 * p) - xn q)). + rewrite inject_Q_plus. apply CReal_plus_le_compat. apply CRealLt_asym. destruct (RQ_limit (xn p0) p0); unfold proj1_sig. apply (CReal_lt_le_trans _ (xn p0 + inject_Q (1 # Pos.of_nat p0))). - apply p1. apply CReal_plus_le_compat_l. apply inject_Q_le. + apply rmaj. apply CReal_plus_le_compat_l. apply inject_Q_le. apply Z2Nat.inj_le. discriminate. discriminate. simpl. assert ((Pos.to_nat p~0 <= p0)%nat). { apply (le_trans _ (Init.Nat.max k (2 * Pos.to_nat p))). 2: apply H. replace (p~0)%positive with (2*p)%positive. 2: reflexivity. rewrite Pos2Nat.inj_mul. apply Nat.le_max_r. } - rewrite Nat2Pos.id. apply H3. intro abs. subst p0. - inversion H3. pose proof (Pos2Nat.is_pos (p~0)). - rewrite H5 in H4. inversion H4. + rewrite Nat2Pos.id. apply H1. intro abs. subst p0. + inversion H1. pose proof (Pos2Nat.is_pos (p~0)). + rewrite H3 in H2. inversion H2. apply CRealLt_asym. rewrite opp_inject_Q. apply CReal_opp_gt_lt_contravar. - destruct (RQ_limit (xn q) q); simpl. apply p1. + destruct (RQ_limit (xn q) q); simpl. apply smaj. + unfold CReal_minus. rewrite (CReal_plus_comm (xn p0)). rewrite CReal_plus_assoc. apply (CReal_plus_le_reg_l (- inject_Q (1 # 2 * p))). rewrite <- CReal_plus_assoc. rewrite CReal_plus_opp_l. rewrite CReal_plus_0_l. rewrite <- opp_inject_Q. rewrite <- inject_Q_plus. setoid_replace (- (1 # 2 * p) + (1 # p))%Q with (1 # 2 * p)%Q. - exact H2. rewrite Qplus_comm. + exact (CReal_le_trans _ _ _ (CReal_le_abs _) cv). + rewrite Qplus_comm. setoid_replace (1#p)%Q with (2 # 2*p)%Q. rewrite Qinv_minus_distr. reflexivity. reflexivity. Qed. -Lemma doubleLeCovariant : forall a b c d e f : CReal, - a == b -> c == d -> e == f - -> (a <= c <= e) - -> (b <= d <= f). +Lemma CReal_absSmall : forall (x y : CReal) (n : positive), + (Qlt (2 # n) + (proj1_sig x (Pos.to_nat n) - Qabs (proj1_sig y (Pos.to_nat n)))) + -> CReal_abs y <= x. Proof. - split. rewrite <- H. rewrite <- H0. apply H2. - rewrite <- H0. rewrite <- H1. apply H2. + intros x y n maj. apply CReal_abs_le. split. + - apply CRealLt_asym. exists n. destruct x as [xn caux], y as [yn cauy]; simpl. + simpl in maj. unfold Qminus. rewrite Qopp_involutive. + rewrite Qplus_comm. + apply (Qlt_le_trans _ (xn (Pos.to_nat n) - Qabs (yn (Pos.to_nat n)))). + apply maj. apply Qplus_le_r. + rewrite <- (Qopp_involutive (yn (Pos.to_nat n))). + apply Qopp_le_compat. rewrite Qabs_opp. apply Qle_Qabs. + - apply CRealLt_asym. exists n. destruct x as [xn caux], y as [yn cauy]; simpl. + simpl in maj. + apply (Qlt_le_trans _ (xn (Pos.to_nat n) - Qabs (yn (Pos.to_nat n)))). + apply maj. apply Qplus_le_r. apply Qopp_le_compat. apply Qle_Qabs. Qed. + (* An element of CReal is a Cauchy sequence of rational numbers, show that it converges to itself in CReal. *) Lemma CReal_cv_self : forall (qn : nat -> Q) (x : CReal) (cvmod : positive -> nat), QSeqEquiv qn (fun n => proj1_sig x n) cvmod - -> Un_cv_mod (fun n => inject_Q (qn n)) x. + -> seq_cv (fun n => inject_Q (qn n)) x. Proof. intros qn x cvmod H p. specialize (H (2*p)%positive). exists (cvmod (2*p)%positive). - intros p0 H0. unfold absLe, CReal_minus. - apply (doubleLeCovariant (-inject_Q (1#p)) _ (inject_Q (qn p0) - x) _ (inject_Q (1#p))). - reflexivity. reflexivity. reflexivity. - apply (CReal_absSmall _ _ (Pos.max (4 * p)%positive (Pos.of_nat (cvmod (2 * p)%positive)))). + intros p0 H0. + apply (CReal_absSmall + _ _ (Pos.max (4 * p)%positive (Pos.of_nat (cvmod (2 * p)%positive)))). setoid_replace (proj1_sig (inject_Q (1 # p)) (Pos.to_nat (Pos.max (4 * p) (Pos.of_nat (cvmod (2 * p)%positive))))) with (1 # p)%Q. 2: reflexivity. @@ -266,22 +322,12 @@ Proof. reflexivity. reflexivity. Qed. -Lemma Un_cv_extens : forall (xn yn : nat -> CReal) (l : CReal), - Un_cv_mod xn l - -> (forall n : nat, xn n == yn n) - -> Un_cv_mod yn l. -Proof. - intros. intro p. destruct (H p) as [n cv]. exists n. - intros. unfold absLe, CReal_minus. - split; rewrite <- (H0 i); apply cv; apply H1. -Qed. - (* Q is dense in Archimedean fields, so all real numbers are limits of rational sequences. The biggest computable such field has all rational limits. *) Lemma R_has_all_rational_limits : forall qn : nat -> Q, Un_cauchy_Q qn - -> { r : CReal & Un_cv_mod (fun n:nat => inject_Q (qn n)) r }. + -> { r : CReal & seq_cv (fun n:nat => inject_Q (qn n)) r }. Proof. (* qn is an element of CReal. Show that inject_Q qn converges to it in CReal. *) @@ -289,8 +335,7 @@ Proof. destruct (standard_modulus qn (fun p => proj1_sig (H (Pos.succ p)))). - intros p n k H0 H1. destruct (H (Pos.succ p)%positive) as [x a]; simpl in H0,H1. specialize (a n k H0 H1). - apply (Qle_lt_trans _ (1#Pos.succ p)). - apply Qabs_Qle_condition. exact a. + apply (Qle_lt_trans _ (1#Pos.succ p) _ a). apply Pos2Z.pos_lt_pos. simpl. apply Pos.lt_succ_diag_r. - exists (exist _ (fun n : nat => qn (increasing_modulus (fun p : positive => proj1_sig (H (Pos.succ p))) n)) H0). @@ -302,24 +347,25 @@ Qed. Lemma Rcauchy_complete : forall (xn : nat -> CReal), Un_cauchy_mod xn - -> { l : CReal & Un_cv_mod xn l }. + -> { l : CReal & seq_cv xn l }. Proof. intros xn cau. destruct (R_has_all_rational_limits (fun n => let (l,_) := RQ_limit (xn n) n in l) (Rdiag_cauchy_sequence xn cau)) as [l cv]. exists l. intro p. specialize (cv (2*p)%positive) as [k cv]. - exists (max k (2 * Pos.to_nat p)). intros p0 H. specialize (cv p0). - destruct cv as [H0 H1]. apply (le_trans _ (max k (2 * Pos.to_nat p))). - apply Nat.le_max_l. apply H. - destruct (RQ_limit (xn p0) p0) as [q maj]; unfold proj1_sig in H0,H1. - split. + exists (max k (2 * Pos.to_nat p)). intros p0 H. + specialize (cv p0 (le_trans _ _ _ (Nat.le_max_l _ _) H)). + destruct (RQ_limit (xn p0) p0) as [q maj]. + apply CReal_abs_le. split. - apply (CReal_le_trans _ (inject_Q q - inject_Q (1 # 2 * p) - l)). + unfold CReal_minus. rewrite (CReal_plus_comm (inject_Q q)). - apply (CReal_plus_le_reg_l (inject_Q (1 # 2 * p))). - ring_simplify. unfold CReal_minus. rewrite <- opp_inject_Q. rewrite <- inject_Q_plus. - setoid_replace ((1 # 2 * p) + - (1 # p))%Q with (-(1#2*p))%Q. - rewrite opp_inject_Q. apply H0. + apply (CReal_plus_le_reg_r (inject_Q (1 # p) + l - inject_Q q)). + ring_simplify. unfold CReal_minus. + rewrite <- (opp_inject_Q (1# 2*p)), <- inject_Q_plus. + setoid_replace ((1 # p) + - (1 # 2* p))%Q with (1#2*p)%Q. + rewrite CReal_abs_minus_sym in cv. + exact (CReal_le_trans _ _ _ (CReal_le_abs _) cv). setoid_replace (1#p)%Q with (2 # 2*p)%Q. rewrite Qinv_minus_distr. reflexivity. reflexivity. + unfold CReal_minus. @@ -335,48 +381,66 @@ Proof. 2: apply H. replace (p~0)%positive with (2*p)%positive. 2: reflexivity. rewrite Pos2Nat.inj_mul. apply Nat.le_max_r. } - rewrite Nat2Pos.id. apply H2. intro abs. subst p0. - inversion H2. pose proof (Pos2Nat.is_pos (p~0)). - rewrite H4 in H3. inversion H3. + rewrite Nat2Pos.id. apply H0. intro abs. subst p0. + inversion H0. pose proof (Pos2Nat.is_pos (p~0)). + rewrite H2 in H1. inversion H1. - apply (CReal_le_trans _ (inject_Q q - l)). + unfold CReal_minus. do 2 rewrite <- (CReal_plus_comm (-l)). apply CReal_plus_le_compat_l. apply CRealLt_asym, maj. + apply (CReal_le_trans _ (inject_Q (1 # 2 * p))). - apply H1. apply inject_Q_le. - rewrite <- Qplus_0_r. + exact (CReal_le_trans _ _ _ (CReal_le_abs _) cv). + apply inject_Q_le. rewrite <- Qplus_0_r. setoid_replace (1#p)%Q with ((1#2*p)+(1#2*p))%Q. apply Qplus_le_r. discriminate. rewrite Qinv_plus_distr. reflexivity. Qed. -Definition CRealImplem : ConstructiveReals. +Lemma CRealLtIsLinear : isLinearOrder CRealLt. Proof. - assert (isLinearOrder CReal CRealLt) as lin. - { repeat split. exact CRealLt_asym. - exact CReal_lt_trans. - intros. destruct (CRealLt_dec x z y H). - left. exact c. right. exact c. } - apply (Build_ConstructiveReals - CReal CRealLt lin CRealLtProp - CRealLtEpsilon CRealLtForget CRealLtDisjunctEpsilon - (inject_Q 0) (inject_Q 1) - CReal_plus CReal_opp CReal_mult - CReal_isRing CReal_isRingExt CRealLt_0_1 - CReal_plus_lt_compat_l CReal_plus_lt_reg_l - CReal_mult_lt_0_compat - CReal_inv CReal_inv_l CReal_inv_0_lt_compat - inject_Q inject_Q_plus inject_Q_mult - inject_Q_one inject_Q_lt lt_inject_Q - CRealQ_dense Rup_pos). - - intros. destruct (Rcauchy_complete xn) as [l cv]. - intro n. destruct (H n). exists x. intros. - specialize (a i j H0 H1) as [a b]. split. 2: exact b. - rewrite <- opp_inject_Q. - setoid_replace (-(1#n))%Q with (-1#n)%Q. exact a. reflexivity. - exists l. intros p. destruct (cv p). - exists x. intros. specialize (a i H0). split. 2: apply a. - unfold orderLe. - intro abs. setoid_replace (-1#p)%Q with (-(1#p))%Q in abs. - rewrite opp_inject_Q in abs. destruct a. contradiction. - reflexivity. + repeat split. exact CRealLt_asym. + exact CReal_lt_trans. + intros. destruct (CRealLt_dec x z y H). + left. exact c. right. exact c. +Qed. + +Lemma CRealAbsLUB : forall x y : CReal, + x <= y /\ (- x) <= y <-> (CReal_abs x) <= y. +Proof. + split. + - intros [H H0]. apply CReal_abs_le. split. 2: exact H. + apply (CReal_plus_le_reg_r (y-x)). ring_simplify. exact H0. + - intros. apply CReal_abs_def2 in H. destruct H. split. + exact H. fold (-x <= y). + apply (CReal_plus_le_reg_r (x-y)). ring_simplify. exact H0. +Qed. + +Lemma CRealComplete : forall xn : nat -> CReal, + (forall p : positive, + {n : nat | + forall i j : nat, + (n <= i)%nat -> (n <= j)%nat -> (CReal_abs (xn i + - xn j)) <= (inject_Q (1 # p))}) -> + {l : CReal & + forall p : positive, + {n : nat | + forall i : nat, (n <= i)%nat -> (CReal_abs (xn i + - l)) <= (inject_Q (1 # p))}}. +Proof. + intros. destruct (Rcauchy_complete xn) as [l cv]. + intro p. destruct (H p) as [n a]. exists n. intros. + exact (a i j H0 H1). + exists l. intros p. destruct (cv p). + exists x. exact c. Defined. + +Definition CRealConstructive : ConstructiveReals + := Build_ConstructiveReals + CReal CRealLt CRealLtIsLinear CRealLtProp + CRealLtEpsilon CRealLtForget CRealLtDisjunctEpsilon + (inject_Q 0) (inject_Q 1) + CReal_plus CReal_opp CReal_mult + CReal_isRing CReal_isRingExt CRealLt_0_1 + CReal_plus_lt_compat_l CReal_plus_lt_reg_l + CReal_mult_lt_0_compat + CReal_inv CReal_inv_l CReal_inv_0_lt_compat + inject_Q inject_Q_plus inject_Q_mult + inject_Q_one inject_Q_lt lt_inject_Q + CRealQ_dense Rup_pos CReal_abs CRealAbsLUB CRealComplete. diff --git a/theories/Reals/ConstructiveReals.v b/theories/Reals/ConstructiveReals.v deleted file mode 100644 index d6eee518d3..0000000000 --- a/theories/Reals/ConstructiveReals.v +++ /dev/null @@ -1,835 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* <O___,, * (see version control and CREDITS file for authors & dates) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) -(************************************************************************) - -(** An interface for constructive and computable real numbers. - All of its instances are isomorphic (see file ConstructiveRealsMorphisms). - For example it contains the Cauchy reals implemented in file - ConstructivecauchyReals and the sumbool-based Dedekind reals defined by - -Structure R := { - (* The cuts are represented as propositional functions, rather than subsets, - as there are no subsets in type theory. *) - lower : Q -> Prop; - upper : Q -> Prop; - (* The cuts respect equality on Q. *) - lower_proper : Proper (Qeq ==> iff) lower; - upper_proper : Proper (Qeq ==> iff) upper; - (* The cuts are inhabited. *) - lower_bound : { q : Q | lower q }; - upper_bound : { r : Q | upper r }; - (* The lower cut is a lower set. *) - lower_lower : forall q r, q < r -> lower r -> lower q; - (* The lower cut is open. *) - lower_open : forall q, lower q -> exists r, q < r /\ lower r; - (* The upper cut is an upper set. *) - upper_upper : forall q r, q < r -> upper q -> upper r; - (* The upper cut is open. *) - upper_open : forall r, upper r -> exists q, q < r /\ upper q; - (* The cuts are disjoint. *) - disjoint : forall q, ~ (lower q /\ upper q); - (* There is no gap between the cuts. *) - located : forall q r, q < r -> { lower q } + { upper r } -}. - - see github.com/andrejbauer/dedekind-reals for the Prop-based - version of those Dedekind reals (although Prop fails to make - them an instance of ConstructiveReals). - - Any computation about constructive reals, can be worked - in the fastest instance for it; we then transport the results - to all other instances by the isomorphisms. This way of working - is different from the usual interfaces, where we would rather - prove things abstractly, by quantifying universally on the instance. - - The functions of ConstructiveReals do not have a direct impact - on performance, because algorithms will be extracted from instances, - and because fast ConstructiveReals morphisms should be coded - manually. However, since instances are forced to implement - those functions, it is probable that they will also use them - in their algorithms. So those functions hint at what we think - will yield fast and small extracted programs. *) - - -Require Import QArith. - -Definition isLinearOrder (X : Set) (Xlt : X -> X -> Set) : Set - := (forall x y:X, Xlt x y -> Xlt y x -> False) - * (forall x y z : X, Xlt x y -> Xlt y z -> Xlt x z) - * (forall x y z : X, Xlt x z -> Xlt x y + Xlt y z). - -Definition orderEq (X : Set) (Xlt : X -> X -> Set) (x y : X) : Prop - := (Xlt x y -> False) /\ (Xlt y x -> False). - -Definition orderAppart (X : Set) (Xlt : X -> X -> Set) (x y : X) : Set - := Xlt x y + Xlt y x. - -Definition orderLe (X : Set) (Xlt : X -> X -> Set) (x y : X) : Prop - := Xlt y x -> False. - -Definition sig_forall_dec_T : Type - := forall (P : nat -> Prop), (forall n, {P n} + {~P n}) - -> {n | ~P n} + {forall n, P n}. - -Definition sig_not_dec_T : Type := forall P : Prop, { ~~P } + { ~P }. - -Record ConstructiveReals : Type := - { - CRcarrier : Set; - - (* Put this order relation in sort Set rather than Prop, - to allow the definition of fast ConstructiveReals morphisms. - For example, the Cauchy reals do store information in - the proofs of CRlt, which is used in algorithms in sort Set. *) - CRlt : CRcarrier -> CRcarrier -> Set; - CRltLinear : isLinearOrder CRcarrier CRlt; - - (* The propositional truncation of CRlt. It facilitates proofs - when computations are not considered important, for example in - classical reals with extra logical axioms. *) - CRltProp : CRcarrier -> CRcarrier -> Prop; - (* This choice algorithm can be slow, keep it for the classical - quotient of the reals, where computations are blocked by - axioms like LPO. *) - CRltEpsilon : forall x y : CRcarrier, CRltProp x y -> CRlt x y; - CRltForget : forall x y : CRcarrier, CRlt x y -> CRltProp x y; - CRltDisjunctEpsilon : forall a b c d : CRcarrier, - (CRltProp a b \/ CRltProp c d) -> CRlt a b + CRlt c d; - - (* Constants *) - CRzero : CRcarrier; - CRone : CRcarrier; - - (* Addition and multiplication *) - CRplus : CRcarrier -> CRcarrier -> CRcarrier; - CRopp : CRcarrier -> CRcarrier; (* Computable opposite, - stronger than Prop-existence of opposite *) - CRmult : CRcarrier -> CRcarrier -> CRcarrier; - - CRisRing : ring_theory CRzero CRone CRplus CRmult - (fun x y => CRplus x (CRopp y)) CRopp (orderEq CRcarrier CRlt); - CRisRingExt : ring_eq_ext CRplus CRmult CRopp (orderEq CRcarrier CRlt); - - (* Compatibility with order *) - CRzero_lt_one : CRlt CRzero CRone; (* 0 # 1 would only allow 0 < 1 because - of Fmult_lt_0_compat so request 0 < 1 directly. *) - CRplus_lt_compat_l : forall r r1 r2 : CRcarrier, - CRlt r1 r2 -> CRlt (CRplus r r1) (CRplus r r2); - CRplus_lt_reg_l : forall r r1 r2 : CRcarrier, - CRlt (CRplus r r1) (CRplus r r2) -> CRlt r1 r2; - CRmult_lt_0_compat : forall x y : CRcarrier, - CRlt CRzero x -> CRlt CRzero y -> CRlt CRzero (CRmult x y); - - (* A constructive total inverse function on F would need to be continuous, - which is impossible because we cannot connect plus and minus infinities. - Therefore it has to be a partial function, defined on non zero elements. - For this reason we cannot use Coq's field_theory and field tactic. - - To implement Finv by Cauchy sequences we need orderAppart, - ~orderEq is not enough. *) - CRinv : forall x : CRcarrier, orderAppart _ CRlt x CRzero -> CRcarrier; - CRinv_l : forall (r:CRcarrier) (rnz : orderAppart _ CRlt r CRzero), - orderEq _ CRlt (CRmult (CRinv r rnz) r) CRone; - CRinv_0_lt_compat : forall (r : CRcarrier) (rnz : orderAppart _ CRlt r CRzero), - CRlt CRzero r -> CRlt CRzero (CRinv r rnz); - - (* The initial field morphism (in characteristic zero). - The abstract definition by iteration of addition is - probably the slowest. Let each instance implement - a faster (and often simpler) version. *) - CR_of_Q : Q -> CRcarrier; - CR_of_Q_plus : forall q r : Q, orderEq _ CRlt (CR_of_Q (q+r)) - (CRplus (CR_of_Q q) (CR_of_Q r)); - CR_of_Q_mult : forall q r : Q, orderEq _ CRlt (CR_of_Q (q*r)) - (CRmult (CR_of_Q q) (CR_of_Q r)); - CR_of_Q_one : orderEq _ CRlt (CR_of_Q 1) CRone; - CR_of_Q_lt : forall q r : Q, - Qlt q r -> CRlt (CR_of_Q q) (CR_of_Q r); - lt_CR_of_Q : forall q r : Q, - CRlt (CR_of_Q q) (CR_of_Q r) -> Qlt q r; - - (* This function is very fast in both the Cauchy and Dedekind - instances, because this rational number q is almost what - the proof of CRlt x y contains. - This function is also the heart of the computation of - constructive real numbers : it approximates x to any - requested precision y. *) - CR_Q_dense : forall x y : CRcarrier, CRlt x y -> - { q : Q & prod (CRlt x (CR_of_Q q)) - (CRlt (CR_of_Q q) y) }; - CR_archimedean : forall x : CRcarrier, - { n : positive & CRlt x (CR_of_Q (Z.pos n # 1)) }; - - CRminus (x y : CRcarrier) : CRcarrier - := CRplus x (CRopp y); - - (* Definitions of convergence and Cauchy-ness. The formulas - with orderLe or CRlt are logically equivalent, the choice of - orderLe in sort Prop is a question of performance. - It is very rare to turn back to the strict order to - define functions in sort Set, so we prefer to discard - those proofs during extraction. And even in those rare cases, - it is easy to divide epsilon by 2 for example. *) - CR_cv (un : nat -> CRcarrier) (l : CRcarrier) : Set - := forall p:positive, - { n : nat | forall i:nat, le n i - -> orderLe _ CRlt (CR_of_Q (-1#p)) (CRminus (un i) l) - /\ orderLe _ CRlt (CRminus (un i) l) (CR_of_Q (1#p)) }; - CR_cauchy (un : nat -> CRcarrier) : Set - := forall p : positive, - { n : nat | forall i j:nat, le n i -> le n j - -> orderLe _ CRlt (CR_of_Q (-1#p)) (CRminus (un i) (un j)) - /\ orderLe _ CRlt (CRminus (un i) (un j)) (CR_of_Q (1#p)) }; - - (* For the Cauchy reals, this algorithm consists in building - a Cauchy sequence of rationals un : nat -> Q that has - the same limit as xn. For each n:nat, un n is a 1/n - rational approximation of a point of xn that has converged - within 1/n. *) - CR_complete : - forall xn : (nat -> CRcarrier), - CR_cauchy xn -> { l : CRcarrier & CR_cv xn l }; - }. - -Lemma CRlt_asym : forall (R : ConstructiveReals) (x y : CRcarrier R), - CRlt R x y -> CRlt R y x -> False. -Proof. - intros. destruct (CRltLinear R), p. - apply (f x y); assumption. -Qed. - -Lemma CRlt_proper - : forall R : ConstructiveReals, - CMorphisms.Proper - (CMorphisms.respectful (orderEq _ (CRlt R)) - (CMorphisms.respectful (orderEq _ (CRlt R)) CRelationClasses.iffT)) (CRlt R). -Proof. - intros R x y H x0 y0 H0. destruct H, H0. - destruct (CRltLinear R). split. - - intro. destruct (s x y x0). assumption. - contradiction. destruct (s y y0 x0). - assumption. assumption. contradiction. - - intro. destruct (s y x y0). assumption. - contradiction. destruct (s x x0 y0). - assumption. assumption. contradiction. -Qed. - -Lemma CRle_refl : forall (R : ConstructiveReals) (x : CRcarrier R), - CRlt R x x -> False. -Proof. - intros. destruct (CRltLinear R), p. - exact (f x x H H). -Qed. - -Lemma CRle_lt_trans : forall (R : ConstructiveReals) (r1 r2 r3 : CRcarrier R), - (CRlt R r2 r1 -> False) -> CRlt R r2 r3 -> CRlt R r1 r3. -Proof. - intros. destruct (CRltLinear R). - destruct (s r2 r1 r3 H0). contradiction. apply c. -Qed. - -Lemma CRlt_le_trans : forall (R : ConstructiveReals) (r1 r2 r3 : CRcarrier R), - CRlt R r1 r2 -> (CRlt R r3 r2 -> False) -> CRlt R r1 r3. -Proof. - intros. destruct (CRltLinear R). - destruct (s r1 r3 r2 H). apply c. contradiction. -Qed. - -Lemma CRle_trans : forall (R : ConstructiveReals) (x y z : CRcarrier R), - orderLe _ (CRlt R) x y -> orderLe _ (CRlt R) y z -> orderLe _ (CRlt R) x z. -Proof. - intros. intro abs. apply H0. - apply (CRlt_le_trans _ _ x); assumption. -Qed. - -Lemma CRlt_trans : forall (R : ConstructiveReals) (x y z : CRcarrier R), - CRlt R x y -> CRlt R y z -> CRlt R x z. -Proof. - intros. apply (CRlt_le_trans R _ y _ H). - apply CRlt_asym. exact H0. -Defined. - -Lemma CRlt_trans_flip : forall (R : ConstructiveReals) (x y z : CRcarrier R), - CRlt R y z -> CRlt R x y -> CRlt R x z. -Proof. - intros. apply (CRlt_le_trans R _ y). exact H0. - apply CRlt_asym. exact H. -Defined. - -Lemma CReq_refl : forall (R : ConstructiveReals) (x : CRcarrier R), - orderEq _ (CRlt R) x x. -Proof. - split; apply CRle_refl. -Qed. - -Lemma CReq_sym : forall (R : ConstructiveReals) (x y : CRcarrier R), - orderEq _ (CRlt R) x y - -> orderEq _ (CRlt R) y x. -Proof. - intros. destruct H. split; intro abs; contradiction. -Qed. - -Lemma CReq_trans : forall (R : ConstructiveReals) (x y z : CRcarrier R), - orderEq _ (CRlt R) x y - -> orderEq _ (CRlt R) y z - -> orderEq _ (CRlt R) x z. -Proof. - intros. destruct H,H0. destruct (CRltLinear R), p. split. - - intro abs. destruct (s _ y _ abs); contradiction. - - intro abs. destruct (s _ y _ abs); contradiction. -Qed. - -Lemma CR_setoid : forall R : ConstructiveReals, - Setoid_Theory (CRcarrier R) (orderEq _ (CRlt R)). -Proof. - split. intro x. apply CReq_refl. - intros x y. apply CReq_sym. - intros x y z. apply CReq_trans. -Qed. - -Lemma CRplus_0_r : forall (R : ConstructiveReals) (x : CRcarrier R), - orderEq _ (CRlt R) (CRplus R x (CRzero R)) x. -Proof. - intros. destruct (CRisRing R). - apply (CReq_trans R _ (CRplus R (CRzero R) x)). - apply Radd_comm. apply Radd_0_l. -Qed. - -Lemma CRmult_1_r : forall (R : ConstructiveReals) (x : CRcarrier R), - orderEq _ (CRlt R) (CRmult R x (CRone R)) x. -Proof. - intros. destruct (CRisRing R). - apply (CReq_trans R _ (CRmult R (CRone R) x)). - apply Rmul_comm. apply Rmul_1_l. -Qed. - -Lemma CRplus_opp_l : forall (R : ConstructiveReals) (x : CRcarrier R), - orderEq _ (CRlt R) (CRplus R (CRopp R x) x) (CRzero R). -Proof. - intros. destruct (CRisRing R). - apply (CReq_trans R _ (CRplus R x (CRopp R x))). - apply Radd_comm. apply Ropp_def. -Qed. - -Lemma CRplus_lt_compat_r : forall (R : ConstructiveReals) (r r1 r2 : CRcarrier R), - CRlt R r1 r2 -> CRlt R (CRplus R r1 r) (CRplus R r2 r). -Proof. - intros. destruct (CRisRing R). - apply (CRlt_proper R (CRplus R r r1) (CRplus R r1 r) (Radd_comm _ _) - (CRplus R r2 r) (CRplus R r2 r)). - apply CReq_refl. - apply (CRlt_proper R _ _ (CReq_refl _ _) _ (CRplus R r r2)). - apply Radd_comm. apply CRplus_lt_compat_l. exact H. -Qed. - -Lemma CRplus_lt_reg_r : forall (R : ConstructiveReals) (r r1 r2 : CRcarrier R), - CRlt R (CRplus R r1 r) (CRplus R r2 r) -> CRlt R r1 r2. -Proof. - intros. destruct (CRisRing R). - apply (CRlt_proper R (CRplus R r r1) (CRplus R r1 r) (Radd_comm _ _) - (CRplus R r2 r) (CRplus R r2 r)) in H. - 2: apply CReq_refl. - apply (CRlt_proper R _ _ (CReq_refl _ _) _ (CRplus R r r2)) in H. - apply CRplus_lt_reg_l in H. exact H. - apply Radd_comm. -Qed. - -Lemma CRplus_le_compat_l : forall (R : ConstructiveReals) (r r1 r2 : CRcarrier R), - orderLe _ (CRlt R) r1 r2 - -> orderLe _ (CRlt R) (CRplus R r r1) (CRplus R r r2). -Proof. - intros. intros abs. apply CRplus_lt_reg_l in abs. apply H. exact abs. -Qed. - -Lemma CRplus_le_compat_r : forall (R : ConstructiveReals) (r r1 r2 : CRcarrier R), - orderLe _ (CRlt R) r1 r2 - -> orderLe _ (CRlt R) (CRplus R r1 r) (CRplus R r2 r). -Proof. - intros. intros abs. apply CRplus_lt_reg_r in abs. apply H. exact abs. -Qed. - -Lemma CRplus_le_reg_l : forall (R : ConstructiveReals) (r r1 r2 : CRcarrier R), - orderLe _ (CRlt R) (CRplus R r r1) (CRplus R r r2) - -> orderLe _ (CRlt R) r1 r2. -Proof. - intros. intro abs. apply H. clear H. - apply CRplus_lt_compat_l. exact abs. -Qed. - -Lemma CRplus_le_reg_r : forall (R : ConstructiveReals) (r r1 r2 : CRcarrier R), - orderLe _ (CRlt R) (CRplus R r1 r) (CRplus R r2 r) - -> orderLe _ (CRlt R) r1 r2. -Proof. - intros. intro abs. apply H. clear H. - apply CRplus_lt_compat_r. exact abs. -Qed. - -Lemma CRplus_lt_le_compat : - forall (R : ConstructiveReals) (r1 r2 r3 r4 : CRcarrier R), - CRlt R r1 r2 - -> (CRlt R r4 r3 -> False) - -> CRlt R (CRplus R r1 r3) (CRplus R r2 r4). -Proof. - intros. apply (CRlt_le_trans R _ (CRplus R r2 r3)). - apply CRplus_lt_compat_r. exact H. intro abs. - apply CRplus_lt_reg_l in abs. contradiction. -Qed. - -Lemma CRplus_eq_reg_l : forall (R : ConstructiveReals) (r r1 r2 : CRcarrier R), - orderEq _ (CRlt R) (CRplus R r r1) (CRplus R r r2) - -> orderEq _ (CRlt R) r1 r2. -Proof. - intros. - destruct (CRisRingExt R). clear Rmul_ext Ropp_ext. - pose proof (Radd_ext - (CRopp R r) (CRopp R r) (CReq_refl _ _) - _ _ H). - destruct (CRisRing R). - apply (CReq_trans _ r1) in H0. - apply (CReq_trans R _ _ _ H0). - apply (CReq_trans R _ (CRplus R (CRplus R (CRopp R r) r) r2)). - apply Radd_assoc. - apply (CReq_trans R _ (CRplus R (CRzero R) r2)). - apply Radd_ext. apply CRplus_opp_l. apply CReq_refl. - apply Radd_0_l. apply CReq_sym. - apply (CReq_trans R _ (CRplus R (CRplus R (CRopp R r) r) r1)). - apply Radd_assoc. - apply (CReq_trans R _ (CRplus R (CRzero R) r1)). - apply Radd_ext. apply CRplus_opp_l. apply CReq_refl. - apply Radd_0_l. -Qed. - -Lemma CRplus_eq_reg_r : forall (R : ConstructiveReals) (r r1 r2 : CRcarrier R), - orderEq _ (CRlt R) (CRplus R r1 r) (CRplus R r2 r) - -> orderEq _ (CRlt R) r1 r2. -Proof. - intros. apply (CRplus_eq_reg_l R r). - apply (CReq_trans R _ (CRplus R r1 r)). apply (Radd_comm (CRisRing R)). - apply (CReq_trans R _ (CRplus R r2 r)). - exact H. apply (Radd_comm (CRisRing R)). -Qed. - -Lemma CRopp_involutive : forall (R : ConstructiveReals) (r : CRcarrier R), - orderEq _ (CRlt R) (CRopp R (CRopp R r)) r. -Proof. - intros. apply (CRplus_eq_reg_l R (CRopp R r)). - apply (CReq_trans R _ (CRzero R)). apply CRisRing. - apply CReq_sym, (CReq_trans R _ (CRplus R r (CRopp R r))). - apply CRisRing. apply CRisRing. -Qed. - -Lemma CRopp_gt_lt_contravar - : forall (R : ConstructiveReals) (r1 r2 : CRcarrier R), - CRlt R r2 r1 -> CRlt R (CRopp R r1) (CRopp R r2). -Proof. - intros. apply (CRplus_lt_reg_l R r1). - destruct (CRisRing R). - apply (CRle_lt_trans R _ (CRzero R)). apply Ropp_def. - apply (CRplus_lt_compat_l R (CRopp R r2)) in H. - apply (CRle_lt_trans R _ (CRplus R (CRopp R r2) r2)). - apply (CRle_trans R _ (CRplus R r2 (CRopp R r2))). - destruct (Ropp_def r2). exact H0. - destruct (Radd_comm r2 (CRopp R r2)). exact H1. - apply (CRlt_le_trans R _ _ _ H). - destruct (Radd_comm r1 (CRopp R r2)). exact H0. -Qed. - -Lemma CRopp_lt_cancel : forall (R : ConstructiveReals) (r1 r2 : CRcarrier R), - CRlt R (CRopp R r2) (CRopp R r1) -> CRlt R r1 r2. -Proof. - intros. apply (CRplus_lt_compat_r R r1) in H. - destruct (CRplus_opp_l R r1) as [_ H1]. - apply (CRlt_le_trans R _ _ _ H) in H1. clear H. - apply (CRplus_lt_compat_l R r2) in H1. - destruct (CRplus_0_r R r2) as [_ H0]. - apply (CRlt_le_trans R _ _ _ H1) in H0. clear H1. - destruct (Radd_assoc (CRisRing R) r2 (CRopp R r2) r1) as [H _]. - apply (CRle_lt_trans R _ _ _ H) in H0. clear H. - apply (CRle_lt_trans R _ (CRplus R (CRzero R) r1)). - apply (Radd_0_l (CRisRing R)). - apply (CRle_lt_trans R _ (CRplus R (CRplus R r2 (CRopp R r2)) r1)). - 2: exact H0. apply CRplus_le_compat_r. - destruct (Ropp_def (CRisRing R) r2). exact H. -Qed. - -Lemma CRopp_plus_distr : forall (R : ConstructiveReals) (r1 r2 : CRcarrier R), - orderEq _ (CRlt R) (CRopp R (CRplus R r1 r2)) (CRplus R (CRopp R r1) (CRopp R r2)). -Proof. - intros. destruct (CRisRing R), (CRisRingExt R). - apply (CRplus_eq_reg_l R (CRplus R r1 r2)). - apply (CReq_trans R _ (CRzero R)). apply Ropp_def. - apply (CReq_trans R _ (CRplus R (CRplus R r2 r1) (CRplus R (CRopp R r1) (CRopp R r2)))). - apply (CReq_trans R _ (CRplus R r2 (CRplus R r1 (CRplus R (CRopp R r1) (CRopp R r2))))). - apply (CReq_trans R _ (CRplus R r2 (CRopp R r2))). - apply CReq_sym. apply Ropp_def. apply Radd_ext. - apply CReq_refl. - apply (CReq_trans R _ (CRplus R (CRzero R) (CRopp R r2))). - apply CReq_sym, Radd_0_l. - apply (CReq_trans R _ (CRplus R (CRplus R r1 (CRopp R r1)) (CRopp R r2))). - apply Radd_ext. 2: apply CReq_refl. apply CReq_sym, Ropp_def. - apply CReq_sym, Radd_assoc. apply Radd_assoc. - apply Radd_ext. 2: apply CReq_refl. apply Radd_comm. -Qed. - -Lemma CRmult_plus_distr_l : forall (R : ConstructiveReals) (r1 r2 r3 : CRcarrier R), - orderEq _ (CRlt R) (CRmult R r1 (CRplus R r2 r3)) - (CRplus R (CRmult R r1 r2) (CRmult R r1 r3)). -Proof. - intros. destruct (CRisRing R). - apply (CReq_trans R _ (CRmult R (CRplus R r2 r3) r1)). - apply Rmul_comm. - apply (CReq_trans R _ (CRplus R (CRmult R r2 r1) (CRmult R r3 r1))). - apply Rdistr_l. - apply (CReq_trans R _ (CRplus R (CRmult R r1 r2) (CRmult R r3 r1))). - destruct (CRisRingExt R). apply Radd_ext. - apply Rmul_comm. apply CReq_refl. - destruct (CRisRingExt R). apply Radd_ext. - apply CReq_refl. apply Rmul_comm. -Qed. - -(* x == x+x -> x == 0 *) -Lemma CRzero_double : forall (R : ConstructiveReals) (x : CRcarrier R), - orderEq _ (CRlt R) x (CRplus R x x) - -> orderEq _ (CRlt R) x (CRzero R). -Proof. - intros. - apply (CRplus_eq_reg_l R x), CReq_sym, (CReq_trans R _ x). - apply CRplus_0_r. exact H. -Qed. - -Lemma CRmult_0_r : forall (R : ConstructiveReals) (x : CRcarrier R), - orderEq _ (CRlt R) (CRmult R x (CRzero R)) (CRzero R). -Proof. - intros. apply CRzero_double. - apply (CReq_trans R _ (CRmult R x (CRplus R (CRzero R) (CRzero R)))). - destruct (CRisRingExt R). apply Rmul_ext. apply CReq_refl. - apply CReq_sym, CRplus_0_r. - destruct (CRisRing R). apply CRmult_plus_distr_l. -Qed. - -Lemma CRopp_mult_distr_r : forall (R : ConstructiveReals) (r1 r2 : CRcarrier R), - orderEq _ (CRlt R) (CRopp R (CRmult R r1 r2)) - (CRmult R r1 (CRopp R r2)). -Proof. - intros. apply (CRplus_eq_reg_l R (CRmult R r1 r2)). - destruct (CRisRing R). - apply (CReq_trans R _ (CRzero R)). apply Ropp_def. - apply (CReq_trans R _ (CRmult R r1 (CRplus R r2 (CRopp R r2)))). - 2: apply CRmult_plus_distr_l. - apply (CReq_trans R _ (CRmult R r1 (CRzero R))). - apply CReq_sym, CRmult_0_r. - destruct (CRisRingExt R). apply Rmul_ext. apply CReq_refl. - apply CReq_sym, Ropp_def. -Qed. - -Lemma CRopp_mult_distr_l : forall (R : ConstructiveReals) (r1 r2 : CRcarrier R), - orderEq _ (CRlt R) (CRopp R (CRmult R r1 r2)) - (CRmult R (CRopp R r1) r2). -Proof. - intros. apply (CReq_trans R _ (CRmult R r2 (CRopp R r1))). - apply (CReq_trans R _ (CRopp R (CRmult R r2 r1))). - apply (Ropp_ext (CRisRingExt R)). - apply CReq_sym, (Rmul_comm (CRisRing R)). - apply CRopp_mult_distr_r. - apply CReq_sym, (Rmul_comm (CRisRing R)). -Qed. - -Lemma CRmult_lt_compat_r : forall (R : ConstructiveReals) (r r1 r2 : CRcarrier R), - CRlt R (CRzero R) r - -> CRlt R r1 r2 - -> CRlt R (CRmult R r1 r) (CRmult R r2 r). -Proof. - intros. apply (CRplus_lt_reg_r R (CRopp R (CRmult R r1 r))). - apply (CRle_lt_trans R _ (CRzero R)). - apply (Ropp_def (CRisRing R)). - apply (CRlt_le_trans R _ (CRplus R (CRmult R r2 r) (CRmult R (CRopp R r1) r))). - apply (CRlt_le_trans R _ (CRmult R (CRplus R r2 (CRopp R r1)) r)). - apply CRmult_lt_0_compat. 2: exact H. - apply (CRplus_lt_reg_r R r1). - apply (CRle_lt_trans R _ r1). apply (Radd_0_l (CRisRing R)). - apply (CRlt_le_trans R _ r2 _ H0). - apply (CRle_trans R _ (CRplus R r2 (CRplus R (CRopp R r1) r1))). - apply (CRle_trans R _ (CRplus R r2 (CRzero R))). - destruct (CRplus_0_r R r2). exact H1. - apply CRplus_le_compat_l. destruct (CRplus_opp_l R r1). exact H1. - destruct (Radd_assoc (CRisRing R) r2 (CRopp R r1) r1). exact H2. - destruct (CRisRing R). - destruct (Rdistr_l r2 (CRopp R r1) r). exact H2. - apply CRplus_le_compat_l. destruct (CRopp_mult_distr_l R r1 r). - exact H1. -Qed. - -Lemma CRinv_r : forall (R : ConstructiveReals) (r:CRcarrier R) - (rnz : orderAppart _ (CRlt R) r (CRzero R)), - orderEq _ (CRlt R) (CRmult R r (CRinv R r rnz)) (CRone R). -Proof. - intros. apply (CReq_trans R _ (CRmult R (CRinv R r rnz) r)). - apply (CRisRing R). apply CRinv_l. -Qed. - -Lemma CRmult_lt_reg_r : forall (R : ConstructiveReals) (r r1 r2 : CRcarrier R), - CRlt R (CRzero R) r - -> CRlt R (CRmult R r1 r) (CRmult R r2 r) - -> CRlt R r1 r2. -Proof. - intros. apply (CRmult_lt_compat_r R (CRinv R r (inr H))) in H0. - 2: apply CRinv_0_lt_compat, H. - apply (CRle_lt_trans R _ (CRmult R (CRmult R r1 r) (CRinv R r (inr H)))). - - clear H0. apply (CRle_trans R _ (CRmult R r1 (CRone R))). - destruct (CRmult_1_r R r1). exact H0. - apply (CRle_trans R _ (CRmult R r1 (CRmult R r (CRinv R r (inr H))))). - destruct (Rmul_ext (CRisRingExt R) r1 r1 (CReq_refl R r1) - (CRmult R r (CRinv R r (inr H))) (CRone R)). - apply CRinv_r. exact H0. - destruct (Rmul_assoc (CRisRing R) r1 r (CRinv R r (inr H))). exact H1. - - apply (CRlt_le_trans R _ (CRmult R (CRmult R r2 r) (CRinv R r (inr H)))). - exact H0. clear H0. - apply (CRle_trans R _ (CRmult R r2 (CRone R))). - 2: destruct (CRmult_1_r R r2); exact H1. - apply (CRle_trans R _ (CRmult R r2 (CRmult R r (CRinv R r (inr H))))). - destruct (Rmul_assoc (CRisRing R) r2 r (CRinv R r (inr H))). exact H0. - destruct (Rmul_ext (CRisRingExt R) r2 r2 (CReq_refl R r2) - (CRmult R r (CRinv R r (inr H))) (CRone R)). - apply CRinv_r. exact H1. -Qed. - -Lemma CRmult_lt_reg_l : forall (R : ConstructiveReals) (r r1 r2 : CRcarrier R), - CRlt R (CRzero R) r - -> CRlt R (CRmult R r r1) (CRmult R r r2) - -> CRlt R r1 r2. -Proof. - intros. - destruct (Rmul_comm (CRisRing R) r r1) as [H1 _]. - apply (CRle_lt_trans R _ _ _ H1) in H0. clear H1. - destruct (Rmul_comm (CRisRing R) r r2) as [_ H1]. - apply (CRlt_le_trans R _ _ _ H0) in H1. clear H0. - apply CRmult_lt_reg_r in H1. - exact H1. exact H. -Qed. - -Lemma CRmult_le_compat_l : forall (R : ConstructiveReals) (r r1 r2 : CRcarrier R), - CRlt R (CRzero R) r - -> orderLe _ (CRlt R) r1 r2 - -> orderLe _ (CRlt R) (CRmult R r r1) (CRmult R r r2). -Proof. - intros. intro abs. apply CRmult_lt_reg_l in abs. - contradiction. exact H. -Qed. - -Lemma CRmult_le_compat_r : forall (R : ConstructiveReals) (r r1 r2 : CRcarrier R), - CRlt R (CRzero R) r - -> orderLe _ (CRlt R) r1 r2 - -> orderLe _ (CRlt R) (CRmult R r1 r) (CRmult R r2 r). -Proof. - intros. intro abs. apply CRmult_lt_reg_r in abs. - contradiction. exact H. -Qed. - -Lemma CRmult_eq_reg_r : forall (R : ConstructiveReals) (r r1 r2 : CRcarrier R), - orderAppart _ (CRlt R) (CRzero R) r - -> orderEq _ (CRlt R) (CRmult R r1 r) (CRmult R r2 r) - -> orderEq _ (CRlt R) r1 r2. -Proof. - intros. destruct H0,H. - - split. - + intro abs. apply H0. apply CRmult_lt_compat_r. - exact c. exact abs. - + intro abs. apply H1. apply CRmult_lt_compat_r. - exact c. exact abs. - - split. - + intro abs. apply H1. apply CRopp_lt_cancel. - apply (CRle_lt_trans R _ (CRmult R r1 (CRopp R r))). - apply CRopp_mult_distr_r. - apply (CRlt_le_trans R _ (CRmult R r2 (CRopp R r))). - 2: apply CRopp_mult_distr_r. - apply CRmult_lt_compat_r. 2: exact abs. - apply (CRplus_lt_reg_r R r). apply (CRle_lt_trans R _ r). - apply (Radd_0_l (CRisRing R)). - apply (CRlt_le_trans R _ (CRzero R) _ c). - apply CRplus_opp_l. - + intro abs. apply H0. apply CRopp_lt_cancel. - apply (CRle_lt_trans R _ (CRmult R r2 (CRopp R r))). - apply CRopp_mult_distr_r. - apply (CRlt_le_trans R _ (CRmult R r1 (CRopp R r))). - 2: apply CRopp_mult_distr_r. - apply CRmult_lt_compat_r. 2: exact abs. - apply (CRplus_lt_reg_r R r). apply (CRle_lt_trans R _ r). - apply (Radd_0_l (CRisRing R)). - apply (CRlt_le_trans R _ (CRzero R) _ c). - apply CRplus_opp_l. -Qed. - -Lemma CR_of_Q_proper : forall (R : ConstructiveReals) (q r : Q), - q == r -> orderEq _ (CRlt R) (CR_of_Q R q) (CR_of_Q R r). -Proof. - split. - - intro abs. apply lt_CR_of_Q in abs. rewrite H in abs. - exact (Qlt_not_le r r abs (Qle_refl r)). - - intro abs. apply lt_CR_of_Q in abs. rewrite H in abs. - exact (Qlt_not_le r r abs (Qle_refl r)). -Qed. - -Lemma CR_of_Q_zero : forall (R : ConstructiveReals), - orderEq _ (CRlt R) (CR_of_Q R 0) (CRzero R). -Proof. - intros. apply CRzero_double. - apply (CReq_trans R _ (CR_of_Q R (0+0))). apply CR_of_Q_proper. - reflexivity. apply CR_of_Q_plus. -Qed. - -Lemma CR_of_Q_opp : forall (R : ConstructiveReals) (q : Q), - orderEq _ (CRlt R) (CR_of_Q R (-q)) (CRopp R (CR_of_Q R q)). -Proof. - intros. apply (CRplus_eq_reg_l R (CR_of_Q R q)). - apply (CReq_trans R _ (CRzero R)). - apply (CReq_trans R _ (CR_of_Q R (q-q))). - apply CReq_sym, CR_of_Q_plus. - apply (CReq_trans R _ (CR_of_Q R 0)). - apply CR_of_Q_proper. ring. apply CR_of_Q_zero. - apply CReq_sym. apply (CRisRing R). -Qed. - -Lemma CR_of_Q_le : forall (R : ConstructiveReals) (r q : Q), - Qle r q - -> orderLe _ (CRlt R) (CR_of_Q R r) (CR_of_Q R q). -Proof. - intros. intro abs. apply lt_CR_of_Q in abs. - exact (Qlt_not_le _ _ abs H). -Qed. - -Lemma CR_of_Q_pos : forall (R : ConstructiveReals) (q:Q), - Qlt 0 q -> CRlt R (CRzero R) (CR_of_Q R q). -Proof. - intros. apply (CRle_lt_trans R _ (CR_of_Q R 0)). - apply CR_of_Q_zero. apply CR_of_Q_lt. exact H. -Qed. - -Lemma CR_cv_above_rat - : forall (R : ConstructiveReals) (xn : nat -> Q) (x : CRcarrier R) (q : Q), - CR_cv R (fun n : nat => CR_of_Q R (xn n)) x - -> CRlt R (CR_of_Q R q) x - -> { n : nat | forall p:nat, le n p -> Qlt q (xn p) }. -Proof. - intros. - destruct (CR_Q_dense R _ _ H0) as [r [H1 H2]]. - apply lt_CR_of_Q in H1. clear H0. - destruct (Qarchimedean (/(r-q))) as [p pmaj]. - destruct (H p) as [n nmaj]. - exists n. intros k lenk. specialize (nmaj k lenk) as [H3 _]. - apply (lt_CR_of_Q R), (CRlt_le_trans R _ (CRplus R x (CR_of_Q R (-1#p)))). - apply (CRlt_trans R _ (CRplus R (CR_of_Q R r) (CR_of_Q R (-1#p)))). - 2: apply CRplus_lt_compat_r, H2. - apply (CRlt_le_trans R _ (CR_of_Q R (r+(-1#p)))). - - apply CR_of_Q_lt. - apply (Qplus_lt_l _ _ (-(-1#p)-q)). field_simplify. - setoid_replace (-1*(-1#p)) with (1#p). 2: reflexivity. - apply (Qmult_lt_l _ _ (r-q)) in pmaj. - rewrite Qmult_inv_r in pmaj. apply Qlt_shift_div_r in pmaj. - 2: reflexivity. setoid_replace (-1*q + r) with (r-q). exact pmaj. - ring. intro abs. apply Qlt_minus_iff in H1. - rewrite abs in H1. inversion H1. - apply Qlt_minus_iff in H1. exact H1. - - apply CR_of_Q_plus. - - apply (CRplus_le_reg_r R (CRopp R x)). - apply (CRle_trans R _ (CR_of_Q R (-1#p))). 2: exact H3. clear H3. - apply (CRle_trans R _ (CRplus R (CRopp R x) (CRplus R x (CR_of_Q R (-1 # p))))). - exact (proj1 (Radd_comm (CRisRing R) _ _)). - apply (CRle_trans R _ (CRplus R (CRplus R (CRopp R x) x) (CR_of_Q R (-1 # p)))). - exact (proj2 (Radd_assoc (CRisRing R) _ _ _)). - apply (CRle_trans R _ (CRplus R (CRzero R) (CR_of_Q R (-1 # p)))). - apply CRplus_le_compat_r. exact (proj2 (CRplus_opp_l R _)). - exact (proj2 (Radd_0_l (CRisRing R) _)). -Qed. - -Lemma CR_cv_below_rat - : forall (R : ConstructiveReals) (xn : nat -> Q) (x : CRcarrier R) (q : Q), - CR_cv R (fun n : nat => CR_of_Q R (xn n)) x - -> CRlt R x (CR_of_Q R q) - -> { n : nat | forall p:nat, le n p -> Qlt (xn p) q }. -Proof. - intros. - destruct (CR_Q_dense R _ _ H0) as [r [H1 H2]]. - apply lt_CR_of_Q in H2. clear H0. - destruct (Qarchimedean (/(q-r))) as [p pmaj]. - destruct (H p) as [n nmaj]. - exists n. intros k lenk. specialize (nmaj k lenk) as [_ H4]. - apply (lt_CR_of_Q R), (CRle_lt_trans R _ (CRplus R x (CR_of_Q R (1#p)))). - - apply (CRplus_le_reg_r R (CRopp R x)). - apply (CRle_trans R _ (CR_of_Q R (1#p))). exact H4. clear H4. - apply (CRle_trans R _ (CRplus R (CRopp R x) (CRplus R x (CR_of_Q R (1 # p))))). - 2: exact (proj1 (Radd_comm (CRisRing R) _ _)). - apply (CRle_trans R _ (CRplus R (CRplus R (CRopp R x) x) (CR_of_Q R (1 # p)))). - 2: exact (proj1 (Radd_assoc (CRisRing R) _ _ _)). - apply (CRle_trans R _ (CRplus R (CRzero R) (CR_of_Q R (1 # p)))). - exact (proj1 (Radd_0_l (CRisRing R) _)). - apply CRplus_le_compat_r. exact (proj1 (CRplus_opp_l R _)). - - apply (CRlt_trans R _ (CRplus R (CR_of_Q R r) (CR_of_Q R (1 # p)))). - apply CRplus_lt_compat_r. exact H1. - apply (CRle_lt_trans R _ (CR_of_Q R (r + (1#p)))). - apply CR_of_Q_plus. apply CR_of_Q_lt. - apply (Qmult_lt_l _ _ (q-r)) in pmaj. - rewrite Qmult_inv_r in pmaj. apply Qlt_shift_div_r in pmaj. - apply (Qplus_lt_l _ _ (-r)). field_simplify. - setoid_replace (-1*r + q) with (q-r). exact pmaj. - ring. reflexivity. intro abs. apply Qlt_minus_iff in H2. - rewrite abs in H2. inversion H2. - apply Qlt_minus_iff in H2. exact H2. -Qed. - -Lemma CR_cv_const : forall (R : ConstructiveReals) (x y : CRcarrier R), - CR_cv R (fun _ => x) y -> orderEq _ (CRlt R) x y. -Proof. - intros. destruct (CRisRing R). split. - - intro abs. - destruct (CR_Q_dense R x y abs) as [q [H0 H1]]. - destruct (CR_Q_dense R _ _ H1) as [r [H2 H3]]. - apply lt_CR_of_Q in H2. - destruct (Qarchimedean (/(r-q))) as [p pmaj]. - destruct (H p) as [n nmaj]. specialize (nmaj n (le_refl n)) as [nmaj _]. - apply nmaj. clear nmaj. - apply (CRlt_trans R _ (CR_of_Q R (q-r))). - apply (CRlt_le_trans R _ (CRplus R (CR_of_Q R q) (CRopp R (CR_of_Q R r)))). - + apply CRplus_lt_le_compat. exact H0. - intro H4. apply CRopp_lt_cancel in H4. exact (CRlt_asym R _ _ H4 H3). - + apply (CRle_trans R _ (CRplus R (CR_of_Q R q) (CR_of_Q R (-r)))). - apply CRplus_le_compat_l. exact (proj1 (CR_of_Q_opp R r)). - exact (proj1 (CR_of_Q_plus R _ _)). - + apply CR_of_Q_lt. - apply (Qplus_lt_l _ _ (-(-1#p)+r-q)). field_simplify. - setoid_replace (-1*(-1#p)) with (1#p). 2: reflexivity. - apply (Qmult_lt_l _ _ (r-q)) in pmaj. - rewrite Qmult_inv_r in pmaj. apply Qlt_shift_div_r in pmaj. - 2: reflexivity. setoid_replace (-1*q + r) with (r-q). exact pmaj. - ring. intro H4. apply Qlt_minus_iff in H2. - rewrite H4 in H2. inversion H2. - apply Qlt_minus_iff in H2. exact H2. - - intro abs. - destruct (CR_Q_dense R _ _ abs) as [q [H0 H1]]. - destruct (CR_Q_dense R _ _ H0) as [r [H2 H3]]. - apply lt_CR_of_Q in H3. - destruct (Qarchimedean (/(q-r))) as [p pmaj]. - destruct (H p) as [n nmaj]. specialize (nmaj n (le_refl n)) as [_ nmaj]. - apply nmaj. clear nmaj. - apply (CRlt_trans R _ (CR_of_Q R (q-r))). - + apply CR_of_Q_lt. - apply (Qmult_lt_l _ _ (q-r)) in pmaj. - rewrite Qmult_inv_r in pmaj. apply Qlt_shift_div_r in pmaj. - exact pmaj. reflexivity. - intro H4. apply Qlt_minus_iff in H3. - rewrite H4 in H3. inversion H3. - apply Qlt_minus_iff in H3. exact H3. - + apply (CRle_lt_trans R _ (CRplus R (CR_of_Q R q) (CR_of_Q R (-r)))). - apply CR_of_Q_plus. - apply (CRle_lt_trans R _ (CRplus R (CR_of_Q R q) (CRopp R (CR_of_Q R r)))). - apply CRplus_le_compat_l. exact (proj2 (CR_of_Q_opp R r)). - apply CRplus_lt_le_compat. exact H1. - intro H4. apply CRopp_lt_cancel in H4. - exact (CRlt_asym R _ _ H4 H2). -Qed. diff --git a/theories/Reals/ConstructiveRealsLUB.v b/theories/Reals/ConstructiveRealsLUB.v deleted file mode 100644 index cc18bd910d..0000000000 --- a/theories/Reals/ConstructiveRealsLUB.v +++ /dev/null @@ -1,318 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* <O___,, * (see version control and CREDITS file for authors & dates) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) -(************************************************************************) - -(* Proof that LPO and the excluded middle for negations imply - the existence of least upper bounds for all non-empty and bounded - subsets of the real numbers. *) - -Require Import QArith_base. -Require Import Qabs. -Require Import ConstructiveReals. -Require Import ConstructiveCauchyRealsMult. -Require Import ConstructiveRealsMorphisms. -Require Import ConstructiveRcomplete. -Require Import Logic.ConstructiveEpsilon. - -Local Open Scope CReal_scope. - -Definition sig_forall_dec_T : Type - := forall (P : nat -> Prop), (forall n, {P n} + {~P n}) - -> {n | ~P n} + {forall n, P n}. - -Definition sig_not_dec_T : Type := forall P : Prop, { ~~P } + { ~P }. - -Definition is_upper_bound (E:CReal -> Prop) (m:CReal) - := forall x:CReal, E x -> x <= m. - -Definition is_lub (E:CReal -> Prop) (m:CReal) := - is_upper_bound E m /\ (forall b:CReal, is_upper_bound E b -> m <= b). - -Lemma is_upper_bound_dec : - forall (E:CReal -> Prop) (x:CReal), - sig_forall_dec_T - -> sig_not_dec_T - -> { is_upper_bound E x } + { ~is_upper_bound E x }. -Proof. - intros E x lpo sig_not_dec. - destruct (sig_not_dec (~exists y:CReal, E y /\ CRealLtProp x y)). - - left. intros y H. - destruct (CRealLt_lpo_dec x y lpo). 2: exact f. - exfalso. apply n. intro abs. apply abs. - exists y. split. exact H. destruct c. exists x0. exact q. - - right. intro abs. apply n. intros [y [H H0]]. - specialize (abs y H). apply CRealLtEpsilon in H0. contradiction. -Qed. - -Lemma is_upper_bound_epsilon : - forall (E:CReal -> Prop), - sig_forall_dec_T - -> sig_not_dec_T - -> (exists x:CReal, is_upper_bound E x) - -> { n:nat | is_upper_bound E (inject_Q (Z.of_nat n # 1)) }. -Proof. - intros E lpo sig_not_dec Ebound. - apply constructive_indefinite_ground_description_nat. - - intro n. apply is_upper_bound_dec. exact lpo. exact sig_not_dec. - - destruct Ebound as [x H]. destruct (Rup_pos x). exists (Pos.to_nat x0). - intros y ey. specialize (H y ey). - apply CRealLt_asym. apply (CReal_le_lt_trans _ x). - exact H. rewrite positive_nat_Z. exact c. -Qed. - -Lemma is_upper_bound_not_epsilon : - forall E:CReal -> Prop, - sig_forall_dec_T - -> sig_not_dec_T - -> (exists x : CReal, E x) - -> { m:nat | ~is_upper_bound E (-inject_Q (Z.of_nat m # 1)) }. -Proof. - intros E lpo sig_not_dec H. - apply constructive_indefinite_ground_description_nat. - - intro n. destruct (is_upper_bound_dec E (-inject_Q (Z.of_nat n # 1)) lpo sig_not_dec). - right. intro abs. contradiction. left. exact n0. - - destruct H as [x H]. destruct (Rup_pos (-x)) as [n H0]. - exists (Pos.to_nat n). intro abs. specialize (abs x H). - apply abs. rewrite positive_nat_Z. - apply (CReal_plus_lt_reg_l (inject_Q (Z.pos n # 1)-x)). - ring_simplify. exact H0. -Qed. - -(* Decidable Dedekind cuts are Cauchy reals. *) -Record DedekindDecCut : Type := - { - DDupcut : Q -> Prop; - DDproper : forall q r : Q, (q == r -> DDupcut q -> DDupcut r)%Q; - DDlow : Q; - DDhigh : Q; - DDdec : forall q:Q, { DDupcut q } + { ~DDupcut q }; - DDinterval : forall q r : Q, Qle q r -> DDupcut q -> DDupcut r; - DDhighProp : DDupcut DDhigh; - DDlowProp : ~DDupcut DDlow; - }. - -Lemma DDlow_below_up : forall (upcut : DedekindDecCut) (a b : Q), - DDupcut upcut a -> ~DDupcut upcut b -> Qlt b a. -Proof. - intros. destruct (Qlt_le_dec b a). exact q. - exfalso. apply H0. apply (DDinterval upcut a). - exact q. exact H. -Qed. - -Fixpoint DDcut_limit_fix (upcut : DedekindDecCut) (r : Q) (n : nat) : - Qlt 0 r - -> (DDupcut upcut (DDlow upcut + (Z.of_nat n#1) * r)) - -> { q : Q | DDupcut upcut q /\ ~DDupcut upcut (q - r) }. -Proof. - destruct n. - - intros. exfalso. simpl in H0. - apply (DDproper upcut _ (DDlow upcut)) in H0. 2: ring. - exact (DDlowProp upcut H0). - - intros. destruct (DDdec upcut (DDlow upcut + (Z.of_nat n # 1) * r)). - + exact (DDcut_limit_fix upcut r n H d). - + exists (DDlow upcut + (Z.of_nat (S n) # 1) * r)%Q. split. - exact H0. intro abs. - apply (DDproper upcut _ (DDlow upcut + (Z.of_nat n # 1) * r)) in abs. - contradiction. - rewrite Nat2Z.inj_succ. unfold Z.succ. rewrite <- Qinv_plus_distr. - ring. -Qed. - -Lemma DDcut_limit : forall (upcut : DedekindDecCut) (r : Q), - Qlt 0 r - -> { q : Q | DDupcut upcut q /\ ~DDupcut upcut (q - r) }. -Proof. - intros. - destruct (Qarchimedean ((DDhigh upcut - DDlow upcut)/r)) as [n nmaj]. - apply (DDcut_limit_fix upcut r (Pos.to_nat n) H). - apply (Qmult_lt_r _ _ r) in nmaj. 2: exact H. - unfold Qdiv in nmaj. - rewrite <- Qmult_assoc, (Qmult_comm (/r)), Qmult_inv_r, Qmult_1_r in nmaj. - apply (DDinterval upcut (DDhigh upcut)). 2: exact (DDhighProp upcut). - apply Qlt_le_weak. apply (Qplus_lt_r _ _ (-DDlow upcut)). - rewrite Qplus_assoc, <- (Qplus_comm (DDlow upcut)), Qplus_opp_r, - Qplus_0_l, Qplus_comm. - rewrite positive_nat_Z. exact nmaj. - intros abs. rewrite abs in H. exact (Qlt_irrefl 0 H). -Qed. - -Lemma glb_dec_Q : forall upcut : DedekindDecCut, - { x : CReal | forall r:Q, (x < inject_Q r -> DDupcut upcut r) - /\ (inject_Q r < x -> ~DDupcut upcut r) }. -Proof. - intros. - assert (forall a b : Q, Qle a b -> Qle (-b) (-a)). - { intros. apply (Qplus_le_l _ _ (a+b)). ring_simplify. exact H. } - assert (QCauchySeq (fun n:nat => proj1_sig (DDcut_limit - upcut (1#Pos.of_nat n) (eq_refl _))) - Pos.to_nat). - { intros p i j pi pj. - destruct (DDcut_limit upcut (1 # Pos.of_nat i) eq_refl), - (DDcut_limit upcut (1 # Pos.of_nat j) eq_refl); unfold proj1_sig. - apply Qabs_case. intros. - apply (Qplus_lt_l _ _ (x0- (1#p))). ring_simplify. - setoid_replace (x + -1 * (1 # p))%Q with (x - (1 # p))%Q. - 2: ring. apply (Qle_lt_trans _ (x- (1#Pos.of_nat i))). - apply Qplus_le_r. apply H. - apply Z2Nat.inj_le. discriminate. discriminate. simpl. - rewrite Nat2Pos.id. exact pi. intro abs. - subst i. inversion pi. pose proof (Pos2Nat.is_pos p). - rewrite H2 in H1. inversion H1. - apply (DDlow_below_up upcut). apply a0. apply a. - intros. - apply (Qplus_lt_l _ _ (x- (1#p))). ring_simplify. - setoid_replace (x0 + -1 * (1 # p))%Q with (x0 - (1 # p))%Q. - 2: ring. apply (Qle_lt_trans _ (x0- (1#Pos.of_nat j))). - apply Qplus_le_r. apply H. - apply Z2Nat.inj_le. discriminate. discriminate. simpl. - rewrite Nat2Pos.id. exact pj. intro abs. - subst j. inversion pj. pose proof (Pos2Nat.is_pos p). - rewrite H2 in H1. inversion H1. - apply (DDlow_below_up upcut). apply a. apply a0. } - pose (exist (fun qn => QSeqEquiv qn qn Pos.to_nat) _ H0) as l. - exists l. split. - - intros. (* find an upper point between the limit and r *) - destruct H1 as [p pmaj]. - unfold l,proj1_sig in pmaj. - destruct (DDcut_limit upcut (1 # Pos.of_nat (Pos.to_nat p)) eq_refl) as [q qmaj] - ; simpl in pmaj. - apply (DDinterval upcut q). 2: apply qmaj. - apply (Qplus_lt_l _ _ q) in pmaj. ring_simplify in pmaj. - apply (Qle_trans _ ((2#p) + q)). - apply (Qplus_le_l _ _ (-q)). ring_simplify. discriminate. - apply Qlt_le_weak. exact pmaj. - - intros [p pmaj] abs. - unfold l,proj1_sig in pmaj. - destruct (DDcut_limit upcut (1 # Pos.of_nat (Pos.to_nat p)) eq_refl) as [q qmaj] - ; simpl in pmaj. - rewrite Pos2Nat.id in qmaj. - apply (Qplus_lt_r _ _ (r - (2#p))) in pmaj. ring_simplify in pmaj. - destruct qmaj. apply H2. - apply (DDinterval upcut r). 2: exact abs. - apply Qlt_le_weak, (Qlt_trans _ (-1*(2#p) + q) _ pmaj). - apply (Qplus_lt_l _ _ ((2#p) -q)). ring_simplify. - setoid_replace (-1 * (1 # p))%Q with (-(1#p))%Q. - 2: ring. rewrite Qinv_minus_distr. reflexivity. -Qed. - -Lemma is_upper_bound_glb : - forall (E:CReal -> Prop), - sig_not_dec_T - -> sig_forall_dec_T - -> (exists x : CReal, E x) - -> (exists x : CReal, is_upper_bound E x) - -> { x : CReal | forall r:Q, (x < inject_Q r -> is_upper_bound E (inject_Q r)) - /\ (inject_Q r < x -> ~is_upper_bound E (inject_Q r)) }. -Proof. - intros E sig_not_dec lpo Einhab Ebound. - destruct (is_upper_bound_epsilon E lpo sig_not_dec Ebound) as [a luba]. - destruct (is_upper_bound_not_epsilon E lpo sig_not_dec Einhab) as [b glbb]. - pose (fun q => is_upper_bound E (inject_Q q)) as upcut. - assert (forall q:Q, { upcut q } + { ~upcut q } ). - { intro q. apply is_upper_bound_dec. exact lpo. exact sig_not_dec. } - assert (forall q r : Q, (q <= r)%Q -> upcut q -> upcut r). - { intros. intros x Ex. specialize (H1 x Ex). intro abs. - apply H1. apply (CReal_le_lt_trans _ (inject_Q r)). 2: exact abs. - apply inject_Q_le. exact H0. } - assert (upcut (Z.of_nat a # 1)%Q). - { intros x Ex. exact (luba x Ex). } - assert (~upcut (- Z.of_nat b # 1)%Q). - { intros abs. apply glbb. intros x Ex. - specialize (abs x Ex). rewrite <- opp_inject_Q. - exact abs. } - assert (forall q r : Q, (q == r)%Q -> upcut q -> upcut r). - { intros. intros x Ex. specialize (H4 x Ex). rewrite <- H3. exact H4. } - destruct (glb_dec_Q (Build_DedekindDecCut - upcut H3 (-Z.of_nat b # 1)%Q (Z.of_nat a # 1) - H H0 H1 H2)). - simpl in a0. exists x. intro r. split. - - intros. apply a0. exact H4. - - intros H6 abs. specialize (a0 r) as [_ a0]. apply a0. - exact H6. exact abs. -Qed. - -Lemma is_upper_bound_closed : - forall (E:CReal -> Prop) (sig_forall_dec : sig_forall_dec_T) - (sig_not_dec : sig_not_dec_T) - (Einhab : exists x : CReal, E x) - (Ebound : exists x : CReal, is_upper_bound E x), - is_lub - E (proj1_sig (is_upper_bound_glb - E sig_not_dec sig_forall_dec Einhab Ebound)). -Proof. - intros. split. - - intros x Ex. - destruct (is_upper_bound_glb E sig_not_dec sig_forall_dec Einhab Ebound); simpl. - intro abs. destruct (FQ_dense x0 x abs) as [q [qmaj H]]. - specialize (a q) as [a _]. specialize (a qmaj x Ex). - contradiction. - - intros. - destruct (is_upper_bound_glb E sig_not_dec sig_forall_dec Einhab Ebound); simpl. - intro abs. destruct (FQ_dense b x abs) as [q [qmaj H0]]. - specialize (a q) as [_ a]. apply a. exact H0. - intros y Ey. specialize (H y Ey). intro abs2. - apply H. exact (CReal_lt_trans _ (inject_Q q) _ qmaj abs2). -Qed. - -Lemma sig_lub : - forall (E:CReal -> Prop), - sig_forall_dec_T - -> sig_not_dec_T - -> (exists x : CReal, E x) - -> (exists x : CReal, is_upper_bound E x) - -> { u : CReal | is_lub E u }. -Proof. - intros E sig_forall_dec sig_not_dec Einhab Ebound. - pose proof (is_upper_bound_closed E sig_forall_dec sig_not_dec Einhab Ebound). - destruct (is_upper_bound_glb - E sig_not_dec sig_forall_dec Einhab Ebound); simpl in H. - exists x. exact H. -Qed. - -Definition CRis_upper_bound (R : ConstructiveReals) (E:CRcarrier R -> Prop) (m:CRcarrier R) - := forall x:CRcarrier R, E x -> CRlt R m x -> False. - -Lemma CR_sig_lub : - forall (R : ConstructiveReals) (E:CRcarrier R -> Prop), - (forall x y : CRcarrier R, orderEq _ (CRlt R) x y -> (E x <-> E y)) - -> sig_forall_dec_T - -> sig_not_dec_T - -> (exists x : CRcarrier R, E x) - -> (exists x : CRcarrier R, CRis_upper_bound R E x) - -> { u : CRcarrier R | CRis_upper_bound R E u /\ - forall y:CRcarrier R, CRis_upper_bound R E y -> CRlt R y u -> False }. -Proof. - intros. destruct (sig_lub (fun x:CReal => E (CauchyMorph R x)) X X0) as [u ulub]. - - destruct H0. exists (CauchyMorph_inv R x). - specialize (H (CauchyMorph R (CauchyMorph_inv R x)) x - (CauchyMorph_surject R x)) as [_ H]. - exact (H H0). - - destruct H1. exists (CauchyMorph_inv R x). - intros y Ey. specialize (H1 (CauchyMorph R y) Ey). - intros abs. apply H1. - apply (CauchyMorph_increasing R) in abs. - apply (CRle_lt_trans R _ (CauchyMorph R (CauchyMorph_inv R x))). - 2: exact abs. apply (CauchyMorph_surject R x). - - exists (CauchyMorph R u). destruct ulub. split. - + intros y Ey abs. specialize (H2 (CauchyMorph_inv R y)). - simpl in H2. - specialize (H (CauchyMorph R (CauchyMorph_inv R y)) y - (CauchyMorph_surject R y)) as [_ H]. - specialize (H2 (H Ey)). apply H2. - apply CauchyMorph_inv_increasing in abs. - rewrite CauchyMorph_inject in abs. exact abs. - + intros. apply (H3 (CauchyMorph_inv R y)). - intros z Ez abs. specialize (H4 (CauchyMorph R z)). - apply (H4 Ez). apply (CauchyMorph_increasing R) in abs. - apply (CRle_lt_trans R _ (CauchyMorph R (CauchyMorph_inv R y))). - 2: exact abs. apply (CauchyMorph_surject R y). - apply CauchyMorph_inv_increasing in H5. - rewrite CauchyMorph_inject in H5. exact H5. -Qed. diff --git a/theories/Reals/ConstructiveRealsMorphisms.v b/theories/Reals/ConstructiveRealsMorphisms.v deleted file mode 100644 index 4af95e2980..0000000000 --- a/theories/Reals/ConstructiveRealsMorphisms.v +++ /dev/null @@ -1,1158 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* <O___,, * (see version control and CREDITS file for authors & dates) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) -(************************************************************************) - -(** Morphisms used to transport results from any instance of - ConstructiveReals to any other. - Between any two constructive reals structures R1 and R2, - all morphisms R1 -> R2 are extensionally equal. We will - further show that they exist, and so are isomorphisms. - The difference between two morphisms R1 -> R2 is therefore - the speed of computation. - - The canonical isomorphisms we provide here are often very slow, - when a new implementation of constructive reals is added, - it should define its own ad hoc isomorphisms for better speed. - - Apart from the speed, those unique isomorphisms also serve as - sanity checks of the interface ConstructiveReals : - it captures a concept with a strong notion of uniqueness. *) - -Require Import QArith. -Require Import Qabs. -Require Import ConstructiveReals. -Require Import ConstructiveCauchyRealsMult. -Require Import ConstructiveRcomplete. - - -Record ConstructiveRealsMorphism (R1 R2 : ConstructiveReals) : Set := - { - CRmorph : CRcarrier R1 -> CRcarrier R2; - CRmorph_rat : forall q : Q, - orderEq _ (CRlt R2) (CRmorph (CR_of_Q R1 q)) (CR_of_Q R2 q); - CRmorph_increasing : forall x y : CRcarrier R1, - CRlt R1 x y -> CRlt R2 (CRmorph x) (CRmorph y); - }. - - -Lemma CRmorph_increasing_inv - : forall (R1 R2 : ConstructiveReals) - (f : ConstructiveRealsMorphism R1 R2) - (x y : CRcarrier R1), - CRlt R2 (CRmorph _ _ f x) (CRmorph _ _ f y) - -> CRlt R1 x y. -Proof. - intros. destruct (CR_Q_dense R2 _ _ H) as [q [H0 H1]]. - destruct (CR_Q_dense R2 _ _ H0) as [r [H2 H3]]. - apply lt_CR_of_Q, (CR_of_Q_lt R1) in H3. - destruct (CRltLinear R1). - destruct (s _ x _ H3). - - exfalso. apply (CRmorph_increasing _ _ f) in c. - destruct (CRmorph_rat _ _ f r) as [H4 _]. - apply (CRle_lt_trans R2 _ _ _ H4) in c. clear H4. - exact (CRlt_asym R2 _ _ c H2). - - clear H2 H3 r. apply (CRlt_trans R1 _ _ _ c). clear c. - destruct (CR_Q_dense R2 _ _ H1) as [t [H2 H3]]. - apply lt_CR_of_Q, (CR_of_Q_lt R1) in H2. - destruct (s _ y _ H2). exact c. - exfalso. apply (CRmorph_increasing _ _ f) in c. - destruct (CRmorph_rat _ _ f t) as [_ H4]. - apply (CRlt_le_trans R2 _ _ _ c) in H4. clear c. - exact (CRlt_asym R2 _ _ H4 H3). -Qed. - -Lemma CRmorph_unique : forall (R1 R2 : ConstructiveReals) - (f g : ConstructiveRealsMorphism R1 R2) - (x : CRcarrier R1), - orderEq _ (CRlt R2) (CRmorph _ _ f x) (CRmorph _ _ g x). -Proof. - split. - - intro abs. destruct (CR_Q_dense R2 _ _ abs) as [q [H H0]]. - destruct (CRmorph_rat _ _ f q) as [H1 _]. - apply (CRlt_le_trans R2 _ _ _ H) in H1. clear H. - apply CRmorph_increasing_inv in H1. - destruct (CRmorph_rat _ _ g q) as [_ H2]. - apply (CRle_lt_trans R2 _ _ _ H2) in H0. clear H2. - apply CRmorph_increasing_inv in H0. - exact (CRlt_asym R1 _ _ H0 H1). - - intro abs. destruct (CR_Q_dense R2 _ _ abs) as [q [H H0]]. - destruct (CRmorph_rat _ _ f q) as [_ H1]. - apply (CRle_lt_trans R2 _ _ _ H1) in H0. clear H1. - apply CRmorph_increasing_inv in H0. - destruct (CRmorph_rat _ _ g q) as [H2 _]. - apply (CRlt_le_trans R2 _ _ _ H) in H2. clear H. - apply CRmorph_increasing_inv in H2. - exact (CRlt_asym R1 _ _ H0 H2). -Qed. - - -(* The identity is the only endomorphism of constructive reals. - For any ConstructiveReals R1, R2 and any morphisms - f : R1 -> R2 and g : R2 -> R1, - f and g are isomorphisms and are inverses of each other. *) -Lemma Endomorph_id : forall (R : ConstructiveReals) (f : ConstructiveRealsMorphism R R) - (x : CRcarrier R), - orderEq _ (CRlt R) (CRmorph _ _ f x) x. -Proof. - split. - - intro abs. destruct (CR_Q_dense R _ _ abs) as [q [H0 H1]]. - destruct (CRmorph_rat _ _ f q) as [H _]. - apply (CRlt_le_trans R _ _ _ H0) in H. clear H0. - apply CRmorph_increasing_inv in H. - exact (CRlt_asym R _ _ H1 H). - - intro abs. destruct (CR_Q_dense R _ _ abs) as [q [H0 H1]]. - destruct (CRmorph_rat _ _ f q) as [_ H]. - apply (CRle_lt_trans R _ _ _ H) in H1. clear H. - apply CRmorph_increasing_inv in H1. - exact (CRlt_asym R _ _ H1 H0). -Qed. - -Lemma CRmorph_proper : forall (R1 R2 : ConstructiveReals) - (f : ConstructiveRealsMorphism R1 R2) - (x y : CRcarrier R1), - orderEq _ (CRlt R1) x y - -> orderEq _ (CRlt R2) (CRmorph _ _ f x) (CRmorph _ _ f y). -Proof. - split. - - intro abs. apply CRmorph_increasing_inv in abs. - destruct H. contradiction. - - intro abs. apply CRmorph_increasing_inv in abs. - destruct H. contradiction. -Qed. - -Definition CRmorph_compose (R1 R2 R3 : ConstructiveReals) - (f : ConstructiveRealsMorphism R1 R2) - (g : ConstructiveRealsMorphism R2 R3) - : ConstructiveRealsMorphism R1 R3. -Proof. - apply (Build_ConstructiveRealsMorphism - R1 R3 (fun x:CRcarrier R1 => CRmorph _ _ g (CRmorph _ _ f x))). - - intro q. apply (CReq_trans R3 _ (CRmorph R2 R3 g (CR_of_Q R2 q))). - apply CRmorph_proper. apply CRmorph_rat. apply CRmorph_rat. - - intros. apply CRmorph_increasing. apply CRmorph_increasing. exact H. -Defined. - -Lemma CRmorph_le : forall (R1 R2 : ConstructiveReals) - (f : ConstructiveRealsMorphism R1 R2) - (x y : CRcarrier R1), - orderLe _ (CRlt R1) x y - -> orderLe _ (CRlt R2) (CRmorph _ _ f x) (CRmorph _ _ f y). -Proof. - intros. intro abs. apply CRmorph_increasing_inv in abs. contradiction. -Qed. - -Lemma CRmorph_le_inv : forall (R1 R2 : ConstructiveReals) - (f : ConstructiveRealsMorphism R1 R2) - (x y : CRcarrier R1), - orderLe _ (CRlt R2) (CRmorph _ _ f x) (CRmorph _ _ f y) - -> orderLe _ (CRlt R1) x y. -Proof. - intros. intro abs. apply (CRmorph_increasing _ _ f) in abs. contradiction. -Qed. - -Lemma CRmorph_zero : forall (R1 R2 : ConstructiveReals) - (f : ConstructiveRealsMorphism R1 R2), - orderEq _ (CRlt R2) (CRmorph _ _ f (CRzero R1)) (CRzero R2). -Proof. - intros. apply (CReq_trans R2 _ (CRmorph _ _ f (CR_of_Q R1 0))). - apply CRmorph_proper. apply CReq_sym, CR_of_Q_zero. - apply (CReq_trans R2 _ (CR_of_Q R2 0)). - apply CRmorph_rat. apply CR_of_Q_zero. -Qed. - -Lemma CRmorph_one : forall (R1 R2 : ConstructiveReals) - (f : ConstructiveRealsMorphism R1 R2), - orderEq _ (CRlt R2) (CRmorph _ _ f (CRone R1)) (CRone R2). -Proof. - intros. apply (CReq_trans R2 _ (CRmorph _ _ f (CR_of_Q R1 1))). - apply CRmorph_proper. apply CReq_sym, CR_of_Q_one. - apply (CReq_trans R2 _ (CR_of_Q R2 1)). - apply CRmorph_rat. apply CR_of_Q_one. -Qed. - -Lemma CRmorph_opp : forall (R1 R2 : ConstructiveReals) - (f : ConstructiveRealsMorphism R1 R2) - (x : CRcarrier R1), - orderEq _ (CRlt R2) (CRmorph _ _ f (CRopp R1 x)) - (CRopp R2 (CRmorph _ _ f x)). -Proof. - split. - - intro abs. - destruct (CR_Q_dense R2 _ _ abs) as [q [H H0]]. clear abs. - destruct (CRmorph_rat R1 R2 f q) as [H1 _]. - apply (CRlt_le_trans R2 _ _ _ H) in H1. clear H. - apply CRmorph_increasing_inv in H1. - apply CRopp_gt_lt_contravar in H0. - destruct (CR_of_Q_opp R2 q) as [H2 _]. - apply (CRlt_le_trans R2 _ _ _ H0) in H2. clear H0. - pose proof (CRopp_involutive R2 (CRmorph R1 R2 f x)) as [H _]. - apply (CRle_lt_trans R2 _ _ _ H) in H2. clear H. - destruct (CRmorph_rat R1 R2 f (-q)) as [H _]. - apply (CRlt_le_trans R2 _ _ _ H2) in H. clear H2. - apply CRmorph_increasing_inv in H. - destruct (CR_of_Q_opp R1 q) as [_ H2]. - apply (CRlt_le_trans R1 _ _ _ H) in H2. clear H. - apply CRopp_gt_lt_contravar in H2. - pose proof (CRopp_involutive R1 (CR_of_Q R1 q)) as [H _]. - apply (CRle_lt_trans R1 _ _ _ H) in H2. clear H. - exact (CRlt_asym R1 _ _ H1 H2). - - intro abs. - destruct (CR_Q_dense R2 _ _ abs) as [q [H H0]]. clear abs. - destruct (CRmorph_rat R1 R2 f q) as [_ H1]. - apply (CRle_lt_trans R2 _ _ _ H1) in H0. clear H1. - apply CRmorph_increasing_inv in H0. - apply CRopp_gt_lt_contravar in H. - pose proof (CRopp_involutive R2 (CRmorph R1 R2 f x)) as [_ H1]. - apply (CRlt_le_trans R2 _ _ _ H) in H1. clear H. - destruct (CR_of_Q_opp R2 q) as [_ H2]. - apply (CRle_lt_trans R2 _ _ _ H2) in H1. clear H2. - destruct (CRmorph_rat R1 R2 f (-q)) as [_ H]. - apply (CRle_lt_trans R2 _ _ _ H) in H1. clear H. - apply CRmorph_increasing_inv in H1. - destruct (CR_of_Q_opp R1 q) as [H2 _]. - apply (CRle_lt_trans R1 _ _ _ H2) in H1. clear H2. - apply CRopp_gt_lt_contravar in H1. - pose proof (CRopp_involutive R1 (CR_of_Q R1 q)) as [_ H]. - apply (CRlt_le_trans R1 _ _ _ H1) in H. clear H1. - exact (CRlt_asym R1 _ _ H0 H). -Qed. - -Lemma CRplus_pos_rat_lt : forall (R : ConstructiveReals) (x : CRcarrier R) (q : Q), - Qlt 0 q -> CRlt R x (CRplus R x (CR_of_Q R q)). -Proof. - intros. - apply (CRle_lt_trans R _ (CRplus R x (CRzero R))). apply CRplus_0_r. - apply CRplus_lt_compat_l. - apply (CRle_lt_trans R _ (CR_of_Q R 0)). apply CR_of_Q_zero. - apply CR_of_Q_lt. exact H. -Defined. - -Lemma CRplus_neg_rat_lt : forall (R : ConstructiveReals) (x : CRcarrier R) (q : Q), - Qlt q 0 -> CRlt R (CRplus R x (CR_of_Q R q)) x. -Proof. - intros. - apply (CRlt_le_trans R _ (CRplus R x (CRzero R))). 2: apply CRplus_0_r. - apply CRplus_lt_compat_l. - apply (CRlt_le_trans R _ (CR_of_Q R 0)). - apply CR_of_Q_lt. exact H. apply CR_of_Q_zero. -Qed. - -Lemma CRmorph_plus_rat : forall (R1 R2 : ConstructiveReals) - (f : ConstructiveRealsMorphism R1 R2) - (x : CRcarrier R1) (q : Q), - orderEq _ (CRlt R2) (CRmorph _ _ f (CRplus R1 x (CR_of_Q R1 q))) - (CRplus R2 (CRmorph _ _ f x) (CR_of_Q R2 q)). -Proof. - split. - - intro abs. - destruct (CR_Q_dense R2 _ _ abs) as [r [H H0]]. clear abs. - destruct (CRmorph_rat _ _ f r) as [H1 _]. - apply (CRlt_le_trans R2 _ _ _ H) in H1. clear H. - apply CRmorph_increasing_inv in H1. - apply (CRlt_asym R1 _ _ H1). clear H1. - apply (CRplus_lt_reg_r R1 (CRopp R1 (CR_of_Q R1 q))). - apply (CRlt_le_trans R1 _ x). - apply (CRle_lt_trans R1 _ (CR_of_Q R1 (r-q))). - apply (CRle_trans R1 _ (CRplus R1 (CR_of_Q R1 r) (CR_of_Q R1 (-q)))). - apply CRplus_le_compat_l. destruct (CR_of_Q_opp R1 q). exact H. - destruct (CR_of_Q_plus R1 r (-q)). exact H. - apply (CRmorph_increasing_inv _ _ f). - apply (CRle_lt_trans R2 _ (CR_of_Q R2 (r - q))). - apply CRmorph_rat. - apply (CRplus_lt_reg_r R2 (CR_of_Q R2 q)). - apply (CRle_lt_trans R2 _ (CR_of_Q R2 r)). 2: exact H0. - intro H. - destruct (CR_of_Q_plus R2 (r-q) q) as [H1 _]. - apply (CRlt_le_trans R2 _ _ _ H) in H1. clear H. - apply lt_CR_of_Q in H1. ring_simplify in H1. - exact (Qlt_not_le _ _ H1 (Qle_refl _)). - destruct (CRisRing R1). - apply (CRle_trans R1 _ (CRplus R1 x (CRplus R1 (CR_of_Q R1 q) (CRopp R1 (CR_of_Q R1 q))))). - apply (CRle_trans R1 _ (CRplus R1 x (CRzero R1))). - destruct (CRplus_0_r R1 x). exact H. - apply CRplus_le_compat_l. destruct (Ropp_def (CR_of_Q R1 q)). exact H. - destruct (Radd_assoc x (CR_of_Q R1 q) (CRopp R1 (CR_of_Q R1 q))). - exact H1. - - intro abs. - destruct (CR_Q_dense R2 _ _ abs) as [r [H H0]]. clear abs. - destruct (CRmorph_rat _ _ f r) as [_ H1]. - apply (CRle_lt_trans R2 _ _ _ H1) in H0. clear H1. - apply CRmorph_increasing_inv in H0. - apply (CRlt_asym R1 _ _ H0). clear H0. - apply (CRplus_lt_reg_r R1 (CRopp R1 (CR_of_Q R1 q))). - apply (CRle_lt_trans R1 _ x). - destruct (CRisRing R1). - apply (CRle_trans R1 _ (CRplus R1 x (CRplus R1 (CR_of_Q R1 q) (CRopp R1 (CR_of_Q R1 q))))). - destruct (Radd_assoc x (CR_of_Q R1 q) (CRopp R1 (CR_of_Q R1 q))). - exact H0. - apply (CRle_trans R1 _ (CRplus R1 x (CRzero R1))). - apply CRplus_le_compat_l. destruct (Ropp_def (CR_of_Q R1 q)). exact H1. - destruct (CRplus_0_r R1 x). exact H1. - apply (CRlt_le_trans R1 _ (CR_of_Q R1 (r-q))). - apply (CRmorph_increasing_inv _ _ f). - apply (CRlt_le_trans R2 _ (CR_of_Q R2 (r - q))). - apply (CRplus_lt_reg_r R2 (CR_of_Q R2 q)). - apply (CRlt_le_trans R2 _ _ _ H). - 2: apply CRmorph_rat. - apply (CRle_trans R2 _ (CR_of_Q R2 (r-q+q))). - intro abs. apply lt_CR_of_Q in abs. ring_simplify in abs. - exact (Qlt_not_le _ _ abs (Qle_refl _)). - destruct (CR_of_Q_plus R2 (r-q) q). exact H1. - apply (CRle_trans R1 _ (CRplus R1 (CR_of_Q R1 r) (CR_of_Q R1 (-q)))). - destruct (CR_of_Q_plus R1 r (-q)). exact H1. - apply CRplus_le_compat_l. destruct (CR_of_Q_opp R1 q). exact H1. -Qed. - -Lemma CRmorph_plus : forall (R1 R2 : ConstructiveReals) - (f : ConstructiveRealsMorphism R1 R2) - (x y : CRcarrier R1), - orderEq _ (CRlt R2) (CRmorph _ _ f (CRplus R1 x y)) - (CRplus R2 (CRmorph _ _ f x) (CRmorph _ _ f y)). -Proof. - intros R1 R2 f. - assert (forall (x y : CRcarrier R1), - orderLe _ (CRlt R2) (CRplus R2 (CRmorph R1 R2 f x) (CRmorph R1 R2 f y)) - (CRmorph R1 R2 f (CRplus R1 x y))). - { intros x y abs. destruct (CR_Q_dense R2 _ _ abs) as [r [H H0]]. clear abs. - destruct (CRmorph_rat _ _ f r) as [H1 _]. - apply (CRlt_le_trans R2 _ _ _ H) in H1. clear H. - apply CRmorph_increasing_inv in H1. - apply (CRlt_asym R1 _ _ H1). clear H1. - destruct (CR_Q_dense R2 _ _ H0) as [q [H2 H3]]. - apply lt_CR_of_Q in H2. - assert (Qlt (r-q) 0) as epsNeg. - { apply (Qplus_lt_r _ _ q). ring_simplify. exact H2. } - destruct (CR_Q_dense R1 _ _ (CRplus_neg_rat_lt R1 x (r-q) epsNeg)) - as [s [H4 H5]]. - apply (CRlt_trans R1 _ (CRplus R1 (CR_of_Q R1 s) y)). - 2: apply CRplus_lt_compat_r, H5. - apply (CRmorph_increasing_inv _ _ f). - apply (CRlt_le_trans R2 _ (CRplus R2 (CR_of_Q R2 s) (CRmorph _ _ f y))). - apply (CRmorph_increasing _ _ f) in H4. - destruct (CRmorph_plus_rat _ _ f x (r-q)) as [H _]. - apply (CRle_lt_trans R2 _ _ _ H) in H4. clear H. - destruct (CRmorph_rat _ _ f s) as [_ H1]. - apply (CRlt_le_trans R2 _ _ _ H4) in H1. clear H4. - apply (CRlt_trans R2 _ (CRplus R2 (CRplus R2 (CRmorph R1 R2 f x) (CR_of_Q R2 (r - q))) - (CRmorph R1 R2 f y))). - 2: apply CRplus_lt_compat_r, H1. - apply (CRlt_le_trans R2 _ (CRplus R2 (CRplus R2 (CR_of_Q R2 (r - q)) (CRmorph R1 R2 f x)) - (CRmorph R1 R2 f y))). - apply (CRlt_le_trans R2 _ (CRplus R2 (CR_of_Q R2 (r - q)) - (CRplus R2 (CRmorph R1 R2 f x) (CRmorph R1 R2 f y)))). - apply (CRle_lt_trans R2 _ (CRplus R2 (CR_of_Q R2 (r - q)) (CR_of_Q R2 q))). - 2: apply CRplus_lt_compat_l, H3. - intro abs. - destruct (CR_of_Q_plus R2 (r-q) q) as [_ H4]. - apply (CRle_lt_trans R2 _ _ _ H4) in abs. clear H4. - destruct (CRmorph_rat _ _ f r) as [_ H4]. - apply (CRlt_le_trans R2 _ _ _ abs) in H4. clear abs. - apply lt_CR_of_Q in H4. ring_simplify in H4. - exact (Qlt_not_le _ _ H4 (Qle_refl _)). - destruct (CRisRing R2); apply Radd_assoc. - apply CRplus_le_compat_r. destruct (CRisRing R2). - destruct (Radd_comm (CRmorph R1 R2 f x) (CR_of_Q R2 (r - q))). - exact H. - intro abs. - destruct (CRmorph_plus_rat _ _ f y s) as [H _]. apply H. clear H. - apply (CRlt_le_trans R2 _ (CRplus R2 (CR_of_Q R2 s) (CRmorph R1 R2 f y))). - apply (CRle_lt_trans R2 _ (CRmorph R1 R2 f (CRplus R1 (CR_of_Q R1 s) y))). - apply CRmorph_proper. destruct (CRisRing R1); apply Radd_comm. - exact abs. destruct (CRisRing R2); apply Radd_comm. } - split. - - apply H. - - specialize (H (CRplus R1 x y) (CRopp R1 y)). - intro abs. apply H. clear H. - apply (CRle_lt_trans R2 _ (CRmorph R1 R2 f x)). - apply CRmorph_proper. destruct (CRisRing R1). - apply (CReq_trans R1 _ (CRplus R1 x (CRplus R1 y (CRopp R1 y)))). - apply CReq_sym, Radd_assoc. - apply (CReq_trans R1 _ (CRplus R1 x (CRzero R1))). 2: apply CRplus_0_r. - destruct (CRisRingExt R1). apply Radd_ext. - apply CReq_refl. apply Ropp_def. - apply (CRplus_lt_reg_r R2 (CRmorph R1 R2 f y)). - apply (CRlt_le_trans R2 _ _ _ abs). clear abs. - apply (CRle_trans R2 _ (CRplus R2 (CRmorph R1 R2 f (CRplus R1 x y)) (CRzero R2))). - destruct (CRplus_0_r R2 (CRmorph R1 R2 f (CRplus R1 x y))). exact H. - apply (CRle_trans R2 _ (CRplus R2 (CRmorph R1 R2 f (CRplus R1 x y)) - (CRplus R2 (CRmorph R1 R2 f (CRopp R1 y)) (CRmorph R1 R2 f y)))). - apply CRplus_le_compat_l. - apply (CRle_trans R2 _ (CRplus R2 (CRopp R2 (CRmorph R1 R2 f y)) (CRmorph R1 R2 f y))). - destruct (CRplus_opp_l R2 (CRmorph R1 R2 f y)). exact H. - apply CRplus_le_compat_r. destruct (CRmorph_opp _ _ f y). exact H. - destruct (CRisRing R2). - destruct (Radd_assoc (CRmorph R1 R2 f (CRplus R1 x y)) - (CRmorph R1 R2 f (CRopp R1 y)) (CRmorph R1 R2 f y)). - exact H0. -Qed. - -Lemma CRmorph_mult_pos : forall (R1 R2 : ConstructiveReals) - (f : ConstructiveRealsMorphism R1 R2) - (x : CRcarrier R1) (n : nat), - orderEq _ (CRlt R2) (CRmorph _ _ f (CRmult R1 x (CR_of_Q R1 (Z.of_nat n # 1)))) - (CRmult R2 (CRmorph _ _ f x) (CR_of_Q R2 (Z.of_nat n # 1))). -Proof. - induction n. - - simpl. destruct (CRisRingExt R1). - apply (CReq_trans R2 _ (CRzero R2)). - + apply (CReq_trans R2 _ (CRmorph R1 R2 f (CRzero R1))). - 2: apply CRmorph_zero. apply CRmorph_proper. - apply (CReq_trans R1 _ (CRmult R1 x (CRzero R1))). - 2: apply CRmult_0_r. apply Rmul_ext. apply CReq_refl. apply CR_of_Q_zero. - + apply (CReq_trans R2 _ (CRmult R2 (CRmorph R1 R2 f x) (CRzero R2))). - apply CReq_sym, CRmult_0_r. destruct (CRisRingExt R2). - apply Rmul_ext0. apply CReq_refl. apply CReq_sym, CR_of_Q_zero. - - destruct (CRisRingExt R1), (CRisRingExt R2). - apply (CReq_trans - R2 _ (CRmorph R1 R2 f (CRplus R1 x (CRmult R1 x (CR_of_Q R1 (Z.of_nat n # 1)))))). - apply CRmorph_proper. - apply (CReq_trans R1 _ (CRmult R1 x (CRplus R1 (CRone R1) (CR_of_Q R1 (Z.of_nat n # 1))))). - apply Rmul_ext. apply CReq_refl. - apply (CReq_trans R1 _ (CR_of_Q R1 (1 + (Z.of_nat n # 1)))). - apply CR_of_Q_proper. rewrite Nat2Z.inj_succ. unfold Z.succ. - rewrite Z.add_comm. rewrite Qinv_plus_distr. reflexivity. - apply (CReq_trans R1 _ (CRplus R1 (CR_of_Q R1 1) (CR_of_Q R1 (Z.of_nat n # 1)))). - apply CR_of_Q_plus. apply Radd_ext. apply CR_of_Q_one. apply CReq_refl. - apply (CReq_trans R1 _ (CRplus R1 (CRmult R1 x (CRone R1)) - (CRmult R1 x (CR_of_Q R1 (Z.of_nat n # 1))))). - apply CRmult_plus_distr_l. apply Radd_ext. apply CRmult_1_r. apply CReq_refl. - apply (CReq_trans R2 _ (CRplus R2 (CRmorph R1 R2 f x) - (CRmorph R1 R2 f (CRmult R1 x (CR_of_Q R1 (Z.of_nat n # 1)))))). - apply CRmorph_plus. - apply (CReq_trans R2 _ (CRplus R2 (CRmorph R1 R2 f x) - (CRmult R2 (CRmorph R1 R2 f x) (CR_of_Q R2 (Z.of_nat n # 1))))). - apply Radd_ext0. apply CReq_refl. exact IHn. - apply (CReq_trans R2 _ (CRmult R2 (CRmorph R1 R2 f x) (CRplus R2 (CRone R2) (CR_of_Q R2 (Z.of_nat n # 1))))). - apply (CReq_trans R2 _ (CRplus R2 (CRmult R2 (CRmorph R1 R2 f x) (CRone R2)) - (CRmult R2 (CRmorph _ _ f x) (CR_of_Q R2 (Z.of_nat n # 1))))). - apply Radd_ext0. 2: apply CReq_refl. apply CReq_sym, CRmult_1_r. - apply CReq_sym, CRmult_plus_distr_l. - apply Rmul_ext0. apply CReq_refl. - apply (CReq_trans R2 _ (CR_of_Q R2 (1 + (Z.of_nat n # 1)))). - apply (CReq_trans R2 _ (CRplus R2 (CR_of_Q R2 1) (CR_of_Q R2 (Z.of_nat n # 1)))). - apply Radd_ext0. apply CReq_sym, CR_of_Q_one. apply CReq_refl. - apply CReq_sym, CR_of_Q_plus. - apply CR_of_Q_proper. rewrite Nat2Z.inj_succ. unfold Z.succ. - rewrite Z.add_comm. rewrite Qinv_plus_distr. reflexivity. -Qed. - -Lemma NatOfZ : forall n : Z, { p : nat | n = Z.of_nat p \/ n = Z.opp (Z.of_nat p) }. -Proof. - intros [|p|n]. - - exists O. left. reflexivity. - - exists (Pos.to_nat p). left. rewrite positive_nat_Z. reflexivity. - - exists (Pos.to_nat n). right. rewrite positive_nat_Z. reflexivity. -Qed. - -Lemma CRmorph_mult_int : forall (R1 R2 : ConstructiveReals) - (f : ConstructiveRealsMorphism R1 R2) - (x : CRcarrier R1) (n : Z), - orderEq _ (CRlt R2) (CRmorph _ _ f (CRmult R1 x (CR_of_Q R1 (n # 1)))) - (CRmult R2 (CRmorph _ _ f x) (CR_of_Q R2 (n # 1))). -Proof. - intros. destruct (NatOfZ n) as [p [pos|neg]]. - - subst n. apply CRmorph_mult_pos. - - subst n. - apply (CReq_trans R2 _ (CRopp R2 (CRmorph R1 R2 f (CRmult R1 x (CR_of_Q R1 (Z.of_nat p # 1)))))). - + apply (CReq_trans R2 _ (CRmorph R1 R2 f (CRopp R1 (CRmult R1 x (CR_of_Q R1 (Z.of_nat p # 1)))))). - 2: apply CRmorph_opp. apply CRmorph_proper. - apply (CReq_trans R1 _ (CRmult R1 x (CR_of_Q R1 (- (Z.of_nat p # 1))))). - destruct (CRisRingExt R1). apply Rmul_ext. apply CReq_refl. - apply CR_of_Q_proper. reflexivity. - apply (CReq_trans R1 _ (CRmult R1 x (CRopp R1 (CR_of_Q R1 (Z.of_nat p # 1))))). - destruct (CRisRingExt R1). apply Rmul_ext. apply CReq_refl. - apply CR_of_Q_opp. apply CReq_sym, CRopp_mult_distr_r. - + apply (CReq_trans R2 _ (CRopp R2 (CRmult R2 (CRmorph R1 R2 f x) (CR_of_Q R2 (Z.of_nat p # 1))))). - destruct (CRisRingExt R2). apply Ropp_ext. apply CRmorph_mult_pos. - apply (CReq_trans R2 _ (CRmult R2 (CRmorph R1 R2 f x) (CRopp R2 (CR_of_Q R2 (Z.of_nat p # 1))))). - apply CRopp_mult_distr_r. destruct (CRisRingExt R2). - apply Rmul_ext. apply CReq_refl. - apply (CReq_trans R2 _ (CR_of_Q R2 (- (Z.of_nat p # 1)))). - apply CReq_sym, CR_of_Q_opp. apply CR_of_Q_proper. reflexivity. -Qed. - -Lemma CRmorph_mult_inv : forall (R1 R2 : ConstructiveReals) - (f : ConstructiveRealsMorphism R1 R2) - (x : CRcarrier R1) (p : positive), - orderEq _ (CRlt R2) (CRmorph _ _ f (CRmult R1 x (CR_of_Q R1 (1 # p)))) - (CRmult R2 (CRmorph _ _ f x) (CR_of_Q R2 (1 # p))). -Proof. - intros. apply (CRmult_eq_reg_r R2 (CR_of_Q R2 (Z.pos p # 1))). - left. apply (CRle_lt_trans R2 _ (CR_of_Q R2 0)). - apply CR_of_Q_zero. apply CR_of_Q_lt. reflexivity. - apply (CReq_trans R2 _ (CRmorph _ _ f x)). - - apply (CReq_trans - R2 _ (CRmorph R1 R2 f (CRmult R1 (CRmult R1 x (CR_of_Q R1 (1 # p))) - (CR_of_Q R1 (Z.pos p # 1))))). - apply CReq_sym, CRmorph_mult_int. apply CRmorph_proper. - apply (CReq_trans - R1 _ (CRmult R1 x (CRmult R1 (CR_of_Q R1 (1 # p)) - (CR_of_Q R1 (Z.pos p # 1))))). - destruct (CRisRing R1). apply CReq_sym, Rmul_assoc. - apply (CReq_trans R1 _ (CRmult R1 x (CRone R1))). - apply (Rmul_ext (CRisRingExt R1)). apply CReq_refl. - apply (CReq_trans R1 _ (CR_of_Q R1 ((1#p) * (Z.pos p # 1)))). - apply CReq_sym, CR_of_Q_mult. - apply (CReq_trans R1 _ (CR_of_Q R1 1)). - apply CR_of_Q_proper. reflexivity. apply CR_of_Q_one. - apply CRmult_1_r. - - apply (CReq_trans R2 _ (CRmult R2 (CRmorph R1 R2 f x) - (CRmult R2 (CR_of_Q R2 (1 # p)) (CR_of_Q R2 (Z.pos p # 1))))). - 2: apply (Rmul_assoc (CRisRing R2)). - apply (CReq_trans R2 _ (CRmult R2 (CRmorph R1 R2 f x) (CRone R2))). - apply CReq_sym, CRmult_1_r. - apply (Rmul_ext (CRisRingExt R2)). apply CReq_refl. - apply (CReq_trans R2 _ (CR_of_Q R2 1)). - apply CReq_sym, CR_of_Q_one. - apply (CReq_trans R2 _ (CR_of_Q R2 ((1#p)*(Z.pos p # 1)))). - apply CR_of_Q_proper. reflexivity. apply CR_of_Q_mult. -Qed. - -Lemma CRmorph_mult_rat : forall (R1 R2 : ConstructiveReals) - (f : ConstructiveRealsMorphism R1 R2) - (x : CRcarrier R1) (q : Q), - orderEq _ (CRlt R2) (CRmorph _ _ f (CRmult R1 x (CR_of_Q R1 q))) - (CRmult R2 (CRmorph _ _ f x) (CR_of_Q R2 q)). -Proof. - intros. destruct q as [a b]. - apply (CReq_trans R2 _ (CRmult R2 (CRmorph _ _ f (CRmult R1 x (CR_of_Q R1 (a # 1)))) - (CR_of_Q R2 (1 # b)))). - - apply (CReq_trans - R2 _ (CRmorph R1 R2 f (CRmult R1 (CRmult R1 x (CR_of_Q R1 (a # 1))) - (CR_of_Q R1 (1 # b))))). - 2: apply CRmorph_mult_inv. apply CRmorph_proper. - apply (CReq_trans R1 _ (CRmult R1 x (CRmult R1 (CR_of_Q R1 (a # 1)) - (CR_of_Q R1 (1 # b))))). - apply (Rmul_ext (CRisRingExt R1)). apply CReq_refl. - apply (CReq_trans R1 _ (CR_of_Q R1 ((a#1)*(1#b)))). - apply CR_of_Q_proper. unfold Qeq; simpl. rewrite Z.mul_1_r. reflexivity. - apply CR_of_Q_mult. - apply (Rmul_assoc (CRisRing R1)). - - apply (CReq_trans R2 _ (CRmult R2 (CRmult R2 (CRmorph _ _ f x) (CR_of_Q R2 (a # 1))) - (CR_of_Q R2 (1 # b)))). - apply (Rmul_ext (CRisRingExt R2)). apply CRmorph_mult_int. - apply CReq_refl. - apply (CReq_trans R2 _ (CRmult R2 (CRmorph R1 R2 f x) - (CRmult R2 (CR_of_Q R2 (a # 1)) (CR_of_Q R2 (1 # b))))). - apply CReq_sym, (Rmul_assoc (CRisRing R2)). - apply (Rmul_ext (CRisRingExt R2)). apply CReq_refl. - apply (CReq_trans R2 _ (CR_of_Q R2 ((a#1)*(1#b)))). - apply CReq_sym, CR_of_Q_mult. - apply CR_of_Q_proper. unfold Qeq; simpl. rewrite Z.mul_1_r. reflexivity. -Qed. - -Lemma CRmorph_mult_pos_pos_le : forall (R1 R2 : ConstructiveReals) - (f : ConstructiveRealsMorphism R1 R2) - (x y : CRcarrier R1), - CRlt R1 (CRzero R1) y - -> orderLe _ (CRlt R2) (CRmult R2 (CRmorph _ _ f x) (CRmorph _ _ f y)) - (CRmorph _ _ f (CRmult R1 x y)). -Proof. - intros. intro abs. destruct (CR_Q_dense R2 _ _ abs) as [q [H1 H2]]. - destruct (CRmorph_rat _ _ f q) as [H3 _]. - apply (CRlt_le_trans R2 _ _ _ H1) in H3. clear H1. - apply CRmorph_increasing_inv in H3. - apply (CRlt_asym R1 _ _ H3). clear H3. - destruct (CR_Q_dense R2 _ _ H2) as [r [H1 H3]]. - apply lt_CR_of_Q in H1. - destruct (CR_archimedean R1 y) as [A Amaj]. - assert (/ ((r - q) * (1 # A)) * (q - r) == - (Z.pos A # 1)) as diveq. - { rewrite Qinv_mult_distr. setoid_replace (q-r) with (-1*(r-q)). - field_simplify. reflexivity. 2: field. - split. intro H4. inversion H4. intro H4. - apply Qlt_minus_iff in H1. rewrite H4 in H1. inversion H1. } - destruct (CR_Q_dense R1 (CRplus R1 x (CR_of_Q R1 ((q-r) * (1#A)))) x) - as [s [H4 H5]]. - - apply (CRlt_le_trans R1 _ (CRplus R1 x (CRzero R1))). - 2: apply CRplus_0_r. apply CRplus_lt_compat_l. - apply (CRplus_lt_reg_l R1 (CR_of_Q R1 ((r-q) * (1#A)))). - apply (CRle_lt_trans R1 _ (CRzero R1)). - apply (CRle_trans R1 _ (CR_of_Q R1 ((r-q)*(1#A) + (q-r)*(1#A)))). - destruct (CR_of_Q_plus R1 ((r-q)*(1#A)) ((q-r)*(1#A))). - exact H0. apply (CRle_trans R1 _ (CR_of_Q R1 0)). - 2: destruct (CR_of_Q_zero R1); exact H4. - intro H4. apply lt_CR_of_Q in H4. ring_simplify in H4. - inversion H4. - apply (CRlt_le_trans R1 _ (CR_of_Q R1 ((r - q) * (1 # A)))). - 2: apply CRplus_0_r. - apply (CRle_lt_trans R1 _ (CR_of_Q R1 0)). - apply CR_of_Q_zero. apply CR_of_Q_lt. - rewrite <- (Qmult_0_r (r-q)). apply Qmult_lt_l. - apply Qlt_minus_iff in H1. exact H1. reflexivity. - - apply (CRmorph_increasing _ _ f) in H4. - destruct (CRmorph_plus _ _ f x (CR_of_Q R1 ((q-r) * (1#A)))) as [H6 _]. - apply (CRle_lt_trans R2 _ _ _ H6) in H4. clear H6. - destruct (CRmorph_rat _ _ f s) as [_ H6]. - apply (CRlt_le_trans R2 _ _ _ H4) in H6. clear H4. - apply (CRmult_lt_compat_r R2 (CRmorph _ _ f y)) in H6. - destruct (Rdistr_l (CRisRing R2) (CRmorph _ _ f x) - (CRmorph R1 R2 f (CR_of_Q R1 ((q-r) * (1#A)))) - (CRmorph _ _ f y)) as [H4 _]. - apply (CRle_lt_trans R2 _ _ _ H4) in H6. clear H4. - apply (CRle_lt_trans R1 _ (CRmult R1 (CR_of_Q R1 s) y)). - 2: apply CRmult_lt_compat_r. 2: exact H. 2: exact H5. - apply (CRmorph_le_inv _ _ f). - apply (CRle_trans R2 _ (CR_of_Q R2 q)). - destruct (CRmorph_rat _ _ f q). exact H4. - apply (CRle_trans R2 _ (CRmult R2 (CR_of_Q R2 s) (CRmorph _ _ f y))). - apply (CRle_trans R2 _ (CRplus R2 (CRmult R2 (CRmorph _ _ f x) (CRmorph _ _ f y)) - (CR_of_Q R2 (q-r)))). - apply (CRle_trans R2 _ (CRplus R2 (CR_of_Q R2 r) (CR_of_Q R2 (q - r)))). - + apply (CRle_trans R2 _ (CR_of_Q R2 (r + (q-r)))). - intro H4. apply lt_CR_of_Q in H4. ring_simplify in H4. - exact (Qlt_not_le q q H4 (Qle_refl q)). - destruct (CR_of_Q_plus R2 r (q-r)). exact H4. - + apply CRplus_le_compat_r. intro H4. - apply (CRlt_asym R2 _ _ H3). exact H4. - + intro H4. apply (CRlt_asym R2 _ _ H4). clear H4. - apply (CRlt_trans_flip R2 _ _ _ H6). clear H6. - apply CRplus_lt_compat_l. - apply (CRlt_le_trans R2 _ (CRmult R2 (CR_of_Q R2 ((q - r) * (1 # A))) (CRmorph R1 R2 f y))). - apply (CRmult_lt_reg_l R2 (CR_of_Q R2 (/((r-q)*(1#A))))). - apply (CRle_lt_trans R2 _ (CR_of_Q R2 0)). apply CR_of_Q_zero. - apply CR_of_Q_lt, Qinv_lt_0_compat. - rewrite <- (Qmult_0_r (r-q)). apply Qmult_lt_l. - apply Qlt_minus_iff in H1. exact H1. reflexivity. - apply (CRle_lt_trans R2 _ (CRopp R2 (CR_of_Q R2 (Z.pos A # 1)))). - apply (CRle_trans R2 _ (CR_of_Q R2 (-(Z.pos A # 1)))). - apply (CRle_trans R2 _ (CR_of_Q R2 ((/ ((r - q) * (1 # A))) * (q - r)))). - destruct (CR_of_Q_mult R2 (/ ((r - q) * (1 # A))) (q - r)). - exact H0. destruct (CR_of_Q_proper R2 (/ ((r - q) * (1 # A)) * (q - r)) - (-(Z.pos A # 1))). - exact diveq. intro H7. apply lt_CR_of_Q in H7. - rewrite diveq in H7. exact (Qlt_not_le _ _ H7 (Qle_refl _)). - destruct (CR_of_Q_opp R2 (Z.pos A # 1)). exact H4. - apply (CRlt_le_trans R2 _ (CRopp R2 (CRmorph _ _ f y))). - apply CRopp_gt_lt_contravar. - apply (CRlt_le_trans R2 _ (CRmorph _ _ f (CR_of_Q R1 (Z.pos A # 1)))). - apply CRmorph_increasing. exact Amaj. - destruct (CRmorph_rat _ _ f (Z.pos A # 1)). exact H4. - apply (CRle_trans R2 _ (CRmult R2 (CRopp R2 (CRone R2)) (CRmorph _ _ f y))). - apply (CRle_trans R2 _ (CRopp R2 (CRmult R2 (CRone R2) (CRmorph R1 R2 f y)))). - destruct (Ropp_ext (CRisRingExt R2) (CRmorph _ _ f y) - (CRmult R2 (CRone R2) (CRmorph R1 R2 f y))). - apply CReq_sym, (Rmul_1_l (CRisRing R2)). exact H4. - destruct (CRopp_mult_distr_l R2 (CRone R2) (CRmorph _ _ f y)). exact H4. - apply (CRle_trans R2 _ (CRmult R2 (CRmult R2 (CR_of_Q R2 (/ ((r - q) * (1 # A)))) - (CR_of_Q R2 ((q - r) * (1 # A)))) - (CRmorph R1 R2 f y))). - apply CRmult_le_compat_r. - apply (CRle_lt_trans R2 _ (CRmorph _ _ f (CRzero R1))). - apply CRmorph_zero. apply CRmorph_increasing. exact H. - apply (CRle_trans R2 _ (CR_of_Q R2 ((/ ((r - q) * (1 # A))) - * ((q - r) * (1 # A))))). - apply (CRle_trans R2 _ (CR_of_Q R2 (-1))). - apply (CRle_trans R2 _ (CRopp R2 (CR_of_Q R2 1))). - destruct (Ropp_ext (CRisRingExt R2) (CRone R2) (CR_of_Q R2 1)). - apply CReq_sym, CR_of_Q_one. exact H4. - destruct (CR_of_Q_opp R2 1). exact H0. - destruct (CR_of_Q_proper R2 (-1) (/ ((r - q) * (1 # A)) * ((q - r) * (1 # A)))). - field. split. - intro H4. inversion H4. intro H4. apply Qlt_minus_iff in H1. - rewrite H4 in H1. inversion H1. exact H4. - destruct (CR_of_Q_mult R2 (/ ((r - q) * (1 # A))) ((q - r) * (1 # A))). - exact H4. - destruct (Rmul_assoc (CRisRing R2) (CR_of_Q R2 (/ ((r - q) * (1 # A)))) - (CR_of_Q R2 ((q - r) * (1 # A))) - (CRmorph R1 R2 f y)). - exact H0. - apply CRmult_le_compat_r. - apply (CRle_lt_trans R2 _ (CRmorph _ _ f (CRzero R1))). - apply CRmorph_zero. apply CRmorph_increasing. exact H. - destruct (CRmorph_rat _ _ f ((q - r) * (1 # A))). exact H0. - + apply (CRle_trans R2 _ (CRmorph _ _ f (CRmult R1 y (CR_of_Q R1 s)))). - apply (CRle_trans R2 _ (CRmult R2 (CRmorph R1 R2 f y) (CR_of_Q R2 s))). - destruct (Rmul_comm (CRisRing R2) (CRmorph R1 R2 f y) (CR_of_Q R2 s)). - exact H0. - destruct (CRmorph_mult_rat _ _ f y s). exact H0. - destruct (CRmorph_proper _ _ f (CRmult R1 y (CR_of_Q R1 s)) - (CRmult R1 (CR_of_Q R1 s) y)). - apply (Rmul_comm (CRisRing R1)). exact H4. - + apply (CRle_lt_trans R2 _ (CRmorph _ _ f (CRzero R1))). - apply CRmorph_zero. apply CRmorph_increasing. exact H. -Qed. - -Lemma CRmorph_mult_pos_pos : forall (R1 R2 : ConstructiveReals) - (f : ConstructiveRealsMorphism R1 R2) - (x y : CRcarrier R1), - CRlt R1 (CRzero R1) y - -> orderEq _ (CRlt R2) (CRmorph _ _ f (CRmult R1 x y)) - (CRmult R2 (CRmorph _ _ f x) (CRmorph _ _ f y)). -Proof. - split. apply CRmorph_mult_pos_pos_le. exact H. - intro abs. destruct (CR_Q_dense R2 _ _ abs) as [q [H1 H2]]. - destruct (CRmorph_rat _ _ f q) as [_ H3]. - apply (CRle_lt_trans R2 _ _ _ H3) in H2. clear H3. - apply CRmorph_increasing_inv in H2. - apply (CRlt_asym R1 _ _ H2). clear H2. - destruct (CR_Q_dense R2 _ _ H1) as [r [H2 H3]]. - apply lt_CR_of_Q in H3. - destruct (CR_archimedean R1 y) as [A Amaj]. - destruct (CR_Q_dense R1 x (CRplus R1 x (CR_of_Q R1 ((q-r) * (1#A))))) - as [s [H4 H5]]. - - apply (CRle_lt_trans R1 _ (CRplus R1 x (CRzero R1))). - apply CRplus_0_r. apply CRplus_lt_compat_l. - apply (CRle_lt_trans R1 _ (CR_of_Q R1 0)). - apply CR_of_Q_zero. apply CR_of_Q_lt. - rewrite <- (Qmult_0_r (q-r)). apply Qmult_lt_l. - apply Qlt_minus_iff in H3. exact H3. reflexivity. - - apply (CRmorph_increasing _ _ f) in H5. - destruct (CRmorph_plus _ _ f x (CR_of_Q R1 ((q-r) * (1#A)))) as [_ H6]. - apply (CRlt_le_trans R2 _ _ _ H5) in H6. clear H5. - destruct (CRmorph_rat _ _ f s) as [H5 _ ]. - apply (CRle_lt_trans R2 _ _ _ H5) in H6. clear H5. - apply (CRmult_lt_compat_r R2 (CRmorph _ _ f y)) in H6. - apply (CRlt_le_trans R1 _ (CRmult R1 (CR_of_Q R1 s) y)). - apply CRmult_lt_compat_r. exact H. exact H4. clear H4. - apply (CRmorph_le_inv _ _ f). - apply (CRle_trans R2 _ (CR_of_Q R2 q)). - 2: destruct (CRmorph_rat _ _ f q); exact H0. - apply (CRle_trans R2 _ (CRmult R2 (CR_of_Q R2 s) (CRmorph R1 R2 f y))). - + apply (CRle_trans R2 _ (CRmorph _ _ f (CRmult R1 y (CR_of_Q R1 s)))). - destruct (CRmorph_proper _ _ f (CRmult R1 (CR_of_Q R1 s) y) - (CRmult R1 y (CR_of_Q R1 s))). - apply (Rmul_comm (CRisRing R1)). exact H4. - apply (CRle_trans R2 _ (CRmult R2 (CRmorph R1 R2 f y) (CR_of_Q R2 s))). - exact (proj2 (CRmorph_mult_rat _ _ f y s)). - destruct (Rmul_comm (CRisRing R2) (CR_of_Q R2 s) (CRmorph R1 R2 f y)). - exact H0. - + intro H5. apply (CRlt_asym R2 _ _ H5). clear H5. - apply (CRlt_trans R2 _ _ _ H6). clear H6. - apply (CRle_lt_trans - R2 _ (CRplus R2 - (CRmult R2 (CRmorph _ _ f x) (CRmorph _ _ f y)) - (CRmult R2 (CRmorph R1 R2 f (CR_of_Q R1 ((q - r) * (1 # A)))) - (CRmorph R1 R2 f y)))). - apply (Rdistr_l (CRisRing R2)). - apply (CRle_lt_trans - R2 _ (CRplus R2 (CR_of_Q R2 r) - (CRmult R2 (CRmorph R1 R2 f (CR_of_Q R1 ((q - r) * (1 # A)))) - (CRmorph R1 R2 f y)))). - apply CRplus_le_compat_r. intro H5. apply (CRlt_asym R2 _ _ H5 H2). - clear H2. - apply (CRle_lt_trans - R2 _ (CRplus R2 (CR_of_Q R2 r) - (CRmult R2 (CR_of_Q R2 ((q - r) * (1 # A))) - (CRmorph R1 R2 f y)))). - apply CRplus_le_compat_l, CRmult_le_compat_r. - apply (CRle_lt_trans R2 _ (CRmorph _ _ f (CRzero R1))). - apply CRmorph_zero. apply CRmorph_increasing. exact H. - destruct (CRmorph_rat _ _ f ((q - r) * (1 # A))). exact H2. - apply (CRlt_le_trans R2 _ (CRplus R2 (CR_of_Q R2 r) - (CR_of_Q R2 ((q - r))))). - apply CRplus_lt_compat_l. - * apply (CRmult_lt_reg_l R2 (CR_of_Q R2 (/((q - r) * (1 # A))))). - apply (CRle_lt_trans R2 _ (CR_of_Q R2 0)). apply CR_of_Q_zero. - apply CR_of_Q_lt, Qinv_lt_0_compat. - rewrite <- (Qmult_0_r (q-r)). apply Qmult_lt_l. - apply Qlt_minus_iff in H3. exact H3. reflexivity. - apply (CRle_lt_trans R2 _ (CRmorph _ _ f y)). - apply (CRle_trans R2 _ (CRmult R2 (CRmult R2 (CR_of_Q R2 (/ ((q - r) * (1 # A)))) - (CR_of_Q R2 ((q - r) * (1 # A)))) - (CRmorph R1 R2 f y))). - exact (proj2 (Rmul_assoc (CRisRing R2) (CR_of_Q R2 (/ ((q - r) * (1 # A)))) - (CR_of_Q R2 ((q - r) * (1 # A))) - (CRmorph _ _ f y))). - apply (CRle_trans R2 _ (CRmult R2 (CRone R2) (CRmorph R1 R2 f y))). - apply CRmult_le_compat_r. - apply (CRle_lt_trans R2 _ (CRmorph _ _ f (CRzero R1))). - apply CRmorph_zero. apply CRmorph_increasing. exact H. - apply (CRle_trans R2 _ (CR_of_Q R2 ((/ ((q - r) * (1 # A))) * ((q - r) * (1 # A))))). - exact (proj1 (CR_of_Q_mult R2 (/ ((q - r) * (1 # A))) ((q - r) * (1 # A)))). - apply (CRle_trans R2 _ (CR_of_Q R2 1)). - destruct (CR_of_Q_proper R2 (/ ((q - r) * (1 # A)) * ((q - r) * (1 # A))) 1). - field_simplify. reflexivity. split. - intro H5. inversion H5. intro H5. apply Qlt_minus_iff in H3. - rewrite H5 in H3. inversion H3. exact H2. - destruct (CR_of_Q_one R2). exact H2. - destruct (Rmul_1_l (CRisRing R2) (CRmorph _ _ f y)). - intro H5. contradiction. - apply (CRlt_le_trans R2 _ (CR_of_Q R2 (Z.pos A # 1))). - apply (CRlt_le_trans R2 _ (CRmorph _ _ f (CR_of_Q R1 (Z.pos A # 1)))). - apply CRmorph_increasing. exact Amaj. - exact (proj2 (CRmorph_rat _ _ f (Z.pos A # 1))). - apply (CRle_trans R2 _ (CR_of_Q R2 ((/ ((q - r) * (1 # A))) * (q - r)))). - 2: exact (proj2 (CR_of_Q_mult R2 (/ ((q - r) * (1 # A))) (q - r))). - destruct (CR_of_Q_proper R2 (Z.pos A # 1) (/ ((q - r) * (1 # A)) * (q - r))). - field_simplify. reflexivity. split. - intro H5. inversion H5. intro H5. apply Qlt_minus_iff in H3. - rewrite H5 in H3. inversion H3. exact H2. - * apply (CRle_trans R2 _ (CR_of_Q R2 (r + (q-r)))). - exact (proj1 (CR_of_Q_plus R2 r (q-r))). - destruct (CR_of_Q_proper R2 (r + (q-r)) q). ring. exact H2. - + apply (CRle_lt_trans R2 _ (CRmorph _ _ f (CRzero R1))). - apply CRmorph_zero. apply CRmorph_increasing. exact H. -Qed. - -Lemma CRmorph_mult : forall (R1 R2 : ConstructiveReals) - (f : ConstructiveRealsMorphism R1 R2) - (x y : CRcarrier R1), - orderEq _ (CRlt R2) (CRmorph _ _ f (CRmult R1 x y)) - (CRmult R2 (CRmorph _ _ f x) (CRmorph _ _ f y)). -Proof. - intros. - destruct (CR_archimedean R1 (CRopp R1 y)) as [p pmaj]. - apply (CRplus_eq_reg_r R2 (CRmult R2 (CRmorph _ _ f x) - (CR_of_Q R2 (Z.pos p # 1)))). - apply (CReq_trans R2 _ (CRmorph _ _ f (CRmult R1 x (CRplus R1 y (CR_of_Q R1 (Z.pos p # 1)))))). - - apply (CReq_trans R2 _ (CRplus R2 (CRmorph R1 R2 f (CRmult R1 x y)) - (CRmorph R1 R2 f (CRmult R1 x (CR_of_Q R1 (Z.pos p # 1)))))). - apply (Radd_ext (CRisRingExt R2)). apply CReq_refl. - apply CReq_sym, CRmorph_mult_int. - apply (CReq_trans R2 _ (CRmorph _ _ f (CRplus R1 (CRmult R1 x y) - (CRmult R1 x (CR_of_Q R1 (Z.pos p # 1)))))). - apply CReq_sym, CRmorph_plus. apply CRmorph_proper. - apply CReq_sym, CRmult_plus_distr_l. - - apply (CReq_trans R2 _ (CRmult R2 (CRmorph _ _ f x) - (CRmorph _ _ f (CRplus R1 y (CR_of_Q R1 (Z.pos p # 1)))))). - apply CRmorph_mult_pos_pos. - apply (CRplus_lt_compat_l R1 y) in pmaj. - apply (CRle_lt_trans R1 _ (CRplus R1 y (CRopp R1 y))). - 2: exact pmaj. apply (CRisRing R1). - apply (CReq_trans R2 _ (CRmult R2 (CRmorph R1 R2 f x) - (CRplus R2 (CRmorph R1 R2 f y) (CR_of_Q R2 (Z.pos p # 1))))). - apply (Rmul_ext (CRisRingExt R2)). apply CReq_refl. - apply (CReq_trans R2 _ (CRplus R2 (CRmorph R1 R2 f y) - (CRmorph _ _ f (CR_of_Q R1 (Z.pos p # 1))))). - apply CRmorph_plus. - apply (Radd_ext (CRisRingExt R2)). apply CReq_refl. - apply CRmorph_rat. - apply CRmult_plus_distr_l. -Qed. - -Lemma CRmorph_appart : forall (R1 R2 : ConstructiveReals) - (f : ConstructiveRealsMorphism R1 R2) - (x y : CRcarrier R1) - (app : orderAppart _ (CRlt R1) x y), - orderAppart _ (CRlt R2) (CRmorph _ _ f x) (CRmorph _ _ f y). -Proof. - intros. destruct app. - - left. apply CRmorph_increasing. exact c. - - right. apply CRmorph_increasing. exact c. -Defined. - -Lemma CRmorph_appart_zero : forall (R1 R2 : ConstructiveReals) - (f : ConstructiveRealsMorphism R1 R2) - (x : CRcarrier R1) - (app : orderAppart _ (CRlt R1) x (CRzero R1)), - orderAppart _ (CRlt R2) (CRmorph _ _ f x) (CRzero R2). -Proof. - intros. destruct app. - - left. apply (CRlt_le_trans R2 _ (CRmorph _ _ f (CRzero R1))). - apply CRmorph_increasing. exact c. - exact (proj2 (CRmorph_zero _ _ f)). - - right. apply (CRle_lt_trans R2 _ (CRmorph _ _ f (CRzero R1))). - exact (proj1 (CRmorph_zero _ _ f)). - apply CRmorph_increasing. exact c. -Defined. - -Lemma CRmorph_inv : forall (R1 R2 : ConstructiveReals) - (f : ConstructiveRealsMorphism R1 R2) - (x : CRcarrier R1) - (xnz : orderAppart _ (CRlt R1) x (CRzero R1)) - (fxnz : orderAppart _ (CRlt R2) (CRmorph _ _ f x) (CRzero R2)), - orderEq _ (CRlt R2) (CRmorph _ _ f (CRinv R1 x xnz)) - (CRinv R2 (CRmorph _ _ f x) fxnz). -Proof. - intros. apply (CRmult_eq_reg_r R2 (CRmorph _ _ f x)). - destruct fxnz. right. exact c. left. exact c. - apply (CReq_trans R2 _ (CRone R2)). - 2: apply CReq_sym, CRinv_l. - apply (CReq_trans R2 _ (CRmorph _ _ f (CRmult R1 (CRinv R1 x xnz) x))). - apply CReq_sym, CRmorph_mult. - apply (CReq_trans R2 _ (CRmorph _ _ f (CRone R1))). - apply CRmorph_proper. apply CRinv_l. - apply CRmorph_one. -Qed. - -Definition CauchyMorph (R : ConstructiveReals) - : CReal -> CRcarrier R. -Proof. - intros [xn xcau]. - destruct (CR_complete R (fun n:nat => CR_of_Q R (xn n))). - - intros p. exists (Pos.to_nat p). intros. - specialize (xcau p i j H H0). apply Qlt_le_weak in xcau. - rewrite Qabs_Qle_condition in xcau. split. - + unfold CRminus. - apply (CRle_trans R _ (CRplus R (CR_of_Q R (xn i)) (CR_of_Q R (-xn j)))). - apply (CRle_trans R _ (CR_of_Q R (xn i-xn j))). - apply CR_of_Q_le. apply xcau. exact (proj2 (CR_of_Q_plus R _ _)). - apply CRplus_le_compat_l. exact (proj2 (CR_of_Q_opp R (xn j))). - + unfold CRminus. - apply (CRle_trans R _ (CRplus R (CR_of_Q R (xn i)) (CR_of_Q R (-xn j)))). - apply CRplus_le_compat_l. exact (proj1 (CR_of_Q_opp R (xn j))). - apply (CRle_trans R _ (CR_of_Q R (xn i-xn j))). - exact (proj1 (CR_of_Q_plus R _ _)). - apply CR_of_Q_le. apply xcau. - - exact x. -Defined. - -Lemma CauchyMorph_rat : forall (R : ConstructiveReals) (q : Q), - orderEq _ (CRlt R) (CauchyMorph R (inject_Q q)) (CR_of_Q R q). -Proof. - intros. - unfold CauchyMorph; simpl; - destruct (CRltLinear R), p, (CR_complete R (fun _ : nat => CR_of_Q R q)). - apply CR_cv_const in c0. apply CReq_sym. exact c0. -Qed. - -Lemma CauchyMorph_increasing_Ql : forall (R : ConstructiveReals) (x : CReal) (q : Q), - CRealLt x (inject_Q q) -> CRlt R (CauchyMorph R x) (CR_of_Q R q). -Proof. - intros. - unfold CauchyMorph; simpl; - destruct x as [xn xcau], (CRltLinear R), p, (CR_complete R (fun n : nat => CR_of_Q R (xn n))). - destruct (CRealQ_dense _ _ H) as [r [H0 H1]]. - apply lt_inject_Q in H1. - destruct (s _ x _ (CR_of_Q_lt R _ _ H1)). 2: exact c1. exfalso. - clear H1 H q. - (* For an index high enough, xn should be both higher - and lower than r, which is absurd. *) - apply CRealLt_above in H0. - destruct H0 as [p pmaj]. simpl in pmaj. - destruct (CR_cv_above_rat R xn x r c0 c1). - assert (x0 <= Nat.max (Pos.to_nat p) (S x0))%nat. - { apply (le_trans _ (S x0)). apply le_S, le_refl. apply Nat.le_max_r. } - specialize (q (Nat.max (Pos.to_nat p) (S x0)) H). clear H. - specialize (pmaj (Pos.max p (Pos.of_nat (S x0))) (Pos.le_max_l _ _)). - rewrite Pos2Nat.inj_max, Nat2Pos.id in pmaj. 2: discriminate. - apply (Qlt_not_le _ _ q). apply Qlt_le_weak. - apply Qlt_minus_iff. apply (Qlt_trans _ (2#p)). reflexivity. exact pmaj. -Qed. - -Lemma CauchyMorph_increasing_Qr : forall (R : ConstructiveReals) (x : CReal) (q : Q), - CRealLt (inject_Q q) x -> CRlt R (CR_of_Q R q) (CauchyMorph R x). -Proof. - intros. - unfold CauchyMorph; simpl; - destruct x as [xn xcau], (CRltLinear R), p, (CR_complete R (fun n : nat => CR_of_Q R (xn n))). - destruct (CRealQ_dense _ _ H) as [r [H0 H1]]. - apply lt_inject_Q in H0. - destruct (s _ x _ (CR_of_Q_lt R _ _ H0)). exact c1. exfalso. - clear H0 H q. - (* For an index high enough, xn should be both higher - and lower than r, which is absurd. *) - apply CRealLt_above in H1. - destruct H1 as [p pmaj]. simpl in pmaj. - destruct (CR_cv_below_rat R xn x r c0 c1). - assert (x0 <= Nat.max (Pos.to_nat p) (S x0))%nat. - { apply (le_trans _ (S x0)). apply le_S, le_refl. apply Nat.le_max_r. } - specialize (q (Nat.max (Pos.to_nat p) (S x0)) H). clear H. - specialize (pmaj (Pos.max p (Pos.of_nat (S x0))) (Pos.le_max_l _ _)). - rewrite Pos2Nat.inj_max, Nat2Pos.id in pmaj. 2: discriminate. - apply (Qlt_not_le _ _ q). apply Qlt_le_weak. - apply Qlt_minus_iff. apply (Qlt_trans _ (2#p)). reflexivity. exact pmaj. -Qed. - -Lemma CauchyMorph_increasing : forall (R : ConstructiveReals) (x y : CReal), - CRealLt x y -> CRlt R (CauchyMorph R x) (CauchyMorph R y). -Proof. - intros. - destruct (CRealQ_dense _ _ H) as [q [H0 H1]]. - apply (CRlt_trans R _ (CR_of_Q R q)). - apply CauchyMorph_increasing_Ql. exact H0. - apply CauchyMorph_increasing_Qr. exact H1. -Qed. - -Definition CauchyMorphism (R : ConstructiveReals) : ConstructiveRealsMorphism CRealImplem R. -Proof. - apply (Build_ConstructiveRealsMorphism CRealImplem R (CauchyMorph R)). - exact (CauchyMorph_rat R). - exact (CauchyMorph_increasing R). -Defined. - -Lemma RightBound : forall (R : ConstructiveReals) (x : CRcarrier R) (p q r : Q), - CRlt R x (CR_of_Q R q) - -> CRlt R x (CR_of_Q R r) - -> CRlt R (CR_of_Q R q) (CRplus R x (CR_of_Q R p)) - -> CRlt R (CR_of_Q R r) (CRplus R x (CR_of_Q R p)) - -> Qlt (Qabs (q - r)) p. -Proof. - intros. apply Qabs_case. - - intros. apply (Qplus_lt_l _ _ r). ring_simplify. - apply (lt_CR_of_Q R), (CRlt_le_trans R _ _ _ H1). - apply (CRle_trans R _ (CRplus R (CR_of_Q R r) (CR_of_Q R p))). - intro abs. apply CRplus_lt_reg_r in abs. - exact (CRlt_asym R _ _ abs H0). - destruct (CR_of_Q_plus R r p). exact H4. - - intros. apply (Qplus_lt_l _ _ q). ring_simplify. - apply (lt_CR_of_Q R), (CRlt_le_trans R _ _ _ H2). - apply (CRle_trans R _ (CRplus R (CR_of_Q R q) (CR_of_Q R p))). - intro abs. apply CRplus_lt_reg_r in abs. - exact (CRlt_asym R _ _ abs H). - destruct (CR_of_Q_plus R q p). exact H4. -Qed. - -Definition CauchyMorph_inv (R : ConstructiveReals) - : CRcarrier R -> CReal. -Proof. - intro x. - exists (fun n:nat => let (q,_) := CR_Q_dense - R x _ (CRplus_pos_rat_lt R x (1 # Pos.of_nat (S n)) (eq_refl _)) - in q). - intros n p q H0 H1. - destruct (CR_Q_dense R x (CRplus R x (CR_of_Q R (1 # Pos.of_nat (S p)))) - (CRplus_pos_rat_lt R x (1 # Pos.of_nat (S p)) (eq_refl _))) - as [r [H2 H3]]. - destruct (CR_Q_dense R x (CRplus R x (CR_of_Q R (1 # Pos.of_nat (S q)))) - (CRplus_pos_rat_lt R x (1 # Pos.of_nat (S q)) (eq_refl _))) - as [s [H4 H5]]. - apply (RightBound R x (1#n) r s). exact H2. exact H4. - apply (CRlt_trans R _ _ _ H3), CRplus_lt_compat_l, CR_of_Q_lt. - unfold Qlt. do 2 rewrite Z.mul_1_l. unfold Qden. - apply Pos2Z.pos_lt_pos, Pos2Nat.inj_lt. rewrite Nat2Pos.id. - 2: discriminate. apply le_n_S. exact H0. - apply (CRlt_trans R _ _ _ H5), CRplus_lt_compat_l, CR_of_Q_lt. - unfold Qlt. do 2 rewrite Z.mul_1_l. unfold Qden. - apply Pos2Z.pos_lt_pos, Pos2Nat.inj_lt. rewrite Nat2Pos.id. - 2: discriminate. apply le_n_S. exact H1. -Defined. - -Lemma CauchyMorph_inv_rat : forall (R : ConstructiveReals) (q : Q), - CRealEq (CauchyMorph_inv R (CR_of_Q R q)) (inject_Q q). -Proof. - split. - - intros [n nmaj]. unfold CauchyMorph_inv, proj1_sig, inject_Q in nmaj. - destruct (CR_Q_dense R (CR_of_Q R q) - (CRplus R (CR_of_Q R q) (CR_of_Q R (1 # Pos.of_nat (S (Pos.to_nat n))))) - (CRplus_pos_rat_lt R (CR_of_Q R q) (1 # Pos.of_nat (S (Pos.to_nat n))) - eq_refl)) - as [r [H _]]. - apply lt_CR_of_Q, Qlt_minus_iff in H. - apply (Qlt_not_le _ _ H), (Qplus_le_l _ _ (q-r)). - ring_simplify. apply (Qle_trans _ (2#n)). discriminate. - apply Qlt_le_weak. ring_simplify in nmaj. rewrite Qplus_comm. exact nmaj. - - intros [n nmaj]. unfold CauchyMorph_inv, proj1_sig, inject_Q in nmaj. - destruct (CR_Q_dense R (CR_of_Q R q) - (CRplus R (CR_of_Q R q) (CR_of_Q R (1 # Pos.of_nat (S (Pos.to_nat n))))) - (CRplus_pos_rat_lt R (CR_of_Q R q) (1 # Pos.of_nat (S (Pos.to_nat n))) - eq_refl)) - as [r [_ H0]]. - destruct (CR_of_Q_plus R q (1 # Pos.of_nat (S (Pos.to_nat n)))) as [H1 _]. - apply (CRlt_le_trans R _ _ _ H0) in H1. clear H0. - apply lt_CR_of_Q, (Qplus_lt_l _ _ (-q)) in H1. - ring_simplify in H1. ring_simplify in nmaj. - apply (Qlt_trans _ _ _ nmaj) in H1. clear nmaj. - apply (Qlt_not_le _ _ H1). clear H1. - apply (Qle_trans _ (1#n)). - unfold Qle, Qnum, Qden. do 2 rewrite Z.mul_1_l. - apply Pos2Z.pos_le_pos. apply Pos2Nat.inj_le. - rewrite Nat2Pos.id. 2: discriminate. apply le_S, le_refl. - unfold Qle, Qnum, Qden. apply Z.mul_le_mono_nonneg_r. - 2: discriminate. apply Pos2Z.pos_is_nonneg. -Qed. - -(* The easier side, because CauchyMorph_inv takes a limit from above. *) -Lemma CauchyMorph_inv_increasing_Qr - : forall (R : ConstructiveReals) (x : CRcarrier R) (q : Q), - CRlt R (CR_of_Q R q) x -> CRealLt (inject_Q q) (CauchyMorph_inv R x). -Proof. - intros. - destruct (CR_Q_dense R _ _ H) as [r [H2 H3]]. - apply lt_CR_of_Q in H2. - destruct (Qarchimedean (/(r-q))) as [p pmaj]. - exists (2*p)%positive. unfold CauchyMorph_inv, inject_Q, proj1_sig. - destruct (CR_Q_dense - R x (CRplus R x (CR_of_Q R (1 # Pos.of_nat (S (Pos.to_nat (2*p)))))) - (CRplus_pos_rat_lt R x (1 # Pos.of_nat (S (Pos.to_nat (2*p)))) eq_refl)) - as [t [H4 H5]]. - setoid_replace (2#2*p) with (1#p). 2: reflexivity. - apply (Qlt_trans _ (r-q)). - apply (Qmult_lt_l _ _ (r-q)) in pmaj. - rewrite Qmult_inv_r in pmaj. - apply Qlt_shift_inv_r in pmaj. 2: reflexivity. exact pmaj. - intro abs. apply Qlt_minus_iff in H2. - rewrite abs in H2. inversion H2. - apply Qlt_minus_iff in H2. exact H2. - apply Qplus_lt_l, (lt_CR_of_Q R), (CRlt_trans R _ x _ H3 H4). -Qed. - -Lemma CauchyMorph_inv_increasing : forall (R : ConstructiveReals) (x y : CRcarrier R), - CRlt R x y -> CRealLt (CauchyMorph_inv R x) (CauchyMorph_inv R y). -Proof. - intros. - destruct (CR_Q_dense R _ _ H) as [q [H0 H1]]. - apply (CReal_lt_trans _ (inject_Q q)). - - clear H1 H y. - destruct (CR_Q_dense R _ _ H0) as [r [H2 H3]]. - apply lt_CR_of_Q in H3. - destruct (Qarchimedean (/(q-r))) as [p pmaj]. - exists (4*p)%positive. unfold CauchyMorph_inv, inject_Q, proj1_sig. - destruct (CR_Q_dense - R x (CRplus R x (CR_of_Q R (1 # Pos.of_nat (S (Pos.to_nat (4*p)))))) - (CRplus_pos_rat_lt R x (1 # Pos.of_nat (S (Pos.to_nat (4*p)))) eq_refl)) - as [t [H4 H5]]. - setoid_replace (2#4*p) with (1#2*p). 2: reflexivity. - assert (1 # 2 * p < (q - r) / 2) as H. - { apply Qlt_shift_div_l. reflexivity. - setoid_replace ((1#2*p)*2) with (1#p). - apply (Qmult_lt_l _ _ (q-r)) in pmaj. - rewrite Qmult_inv_r in pmaj. - apply Qlt_shift_inv_r in pmaj. 2: reflexivity. exact pmaj. - intro abs. apply Qlt_minus_iff in H3. - rewrite abs in H3. inversion H3. - apply Qlt_minus_iff in H3. exact H3. - rewrite Qmult_comm. reflexivity. } - apply (Qlt_trans _ ((q-r)/2)). exact H. - apply (Qplus_lt_l _ _ (t + (r-q)/2)). field_simplify. - setoid_replace (2*t/2) with t. 2: field. - apply (lt_CR_of_Q R). apply (CRlt_trans R _ _ _ H5). - apply (CRlt_trans - R _ (CRplus R (CR_of_Q R r) (CR_of_Q R (1 # Pos.of_nat (S (Pos.to_nat (4 * p))))))). - apply CRplus_lt_compat_r. exact H2. - apply (CRle_lt_trans - R _ (CR_of_Q R (r + (1 # Pos.of_nat (S (Pos.to_nat (4 * p))))))). - apply CR_of_Q_plus. apply CR_of_Q_lt. - apply (Qlt_le_trans _ (r + (q-r)/2)). - 2: field_simplify; apply Qle_refl. - apply Qplus_lt_r. - apply (Qlt_trans _ (1#2*p)). 2: exact H. - unfold Qlt. do 2 rewrite Z.mul_1_l. unfold Qden. - apply Pos2Z.pos_lt_pos. - rewrite Nat2Pos.inj_succ, Pos2Nat.id. - apply (Pos.lt_trans _ (4*p)). apply Pos2Nat.inj_lt. - do 2 rewrite Pos2Nat.inj_mul. - apply Nat.mul_lt_mono_pos_r. apply Pos2Nat.is_pos. - unfold Pos.to_nat. simpl. auto. - apply Pos.lt_succ_diag_r. - intro abs. pose proof (Pos2Nat.is_pos (4*p)). - rewrite abs in H1. inversion H1. - - apply CauchyMorph_inv_increasing_Qr. exact H1. -Qed. - -Definition CauchyMorphismInv (R : ConstructiveReals) - : ConstructiveRealsMorphism R CRealImplem. -Proof. - apply (Build_ConstructiveRealsMorphism R CRealImplem (CauchyMorph_inv R)). - - apply CauchyMorph_inv_rat. - - apply CauchyMorph_inv_increasing. -Defined. - -Lemma CauchyMorph_surject : forall (R : ConstructiveReals) (x : CRcarrier R), - orderEq _ (CRlt R) (CauchyMorph R (CauchyMorph_inv R x)) x. -Proof. - intros. - apply (Endomorph_id - R (CRmorph_compose _ _ _ (CauchyMorphismInv R) (CauchyMorphism R)) x). -Qed. - -Lemma CauchyMorph_inject : forall (R : ConstructiveReals) (x : CReal), - CRealEq (CauchyMorph_inv R (CauchyMorph R x)) x. -Proof. - intros. - apply (Endomorph_id CRealImplem (CRmorph_compose _ _ _ (CauchyMorphism R) (CauchyMorphismInv R)) x). -Qed. - -(* We call this morphism slow to remind that it should only be used - for proofs, not for computations. *) -Definition SlowConstructiveRealsMorphism (R1 R2 : ConstructiveReals) - : ConstructiveRealsMorphism R1 R2 - := CRmorph_compose R1 CRealImplem R2 - (CauchyMorphismInv R1) (CauchyMorphism R2). diff --git a/theories/Reals/Raxioms.v b/theories/Reals/Raxioms.v index 57912a1196..8c5bc8475b 100644 --- a/theories/Reals/Raxioms.v +++ b/theories/Reals/Raxioms.v @@ -24,7 +24,7 @@ Require Import ClassicalDedekindReals. Require Import ConstructiveCauchyReals. Require Import ConstructiveCauchyRealsMult. Require Import ConstructiveRcomplete. -Require Import ConstructiveRealsLUB. +Require Import ConstructiveLUB. Require Export Rdefinitions. Local Open Scope R_scope. @@ -438,7 +438,7 @@ Proof. as Ebound. { destruct H. exists (Rrepr x). intros y Ey. rewrite <- (Rquot2 y). apply Rrepr_le. apply H. exact Ey. } - destruct (CR_sig_lub CRealImplem + destruct (@CR_sig_lub CRealConstructive Er Erproper sig_forall_dec sig_not_dec Einhab Ebound). exists (Rabst x). split. intros y Ey. apply Rrepr_le. rewrite Rquot2. diff --git a/theories/Sorting/Mergesort.v b/theories/Sorting/Mergesort.v index a761dba62d..f6a1efdd37 100644 --- a/theories/Sorting/Mergesort.v +++ b/theories/Sorting/Mergesort.v @@ -230,13 +230,13 @@ Proof. apply IHl. Qed. -Theorem Sorted_sort : forall l, Sorted (sort l). +Theorem LocallySorted_sort : forall l, Sorted (sort l). Proof. intro; apply Sorted_iter_merge. constructor. Qed. -Corollary LocallySorted_sort : forall l, Sorted.Sorted leb (sort l). -Proof. intro; eapply Sorted_LocallySorted_iff, Sorted_sort; auto. Qed. +Corollary Sorted_sort : forall l, Sorted.Sorted leb (sort l). +Proof. intro; eapply Sorted_LocallySorted_iff, LocallySorted_sort; auto. Qed. Theorem Permuted_sort : forall l, Permutation l (sort l). Proof. @@ -245,7 +245,7 @@ Qed. Corollary StronglySorted_sort : forall l, Transitive leb -> StronglySorted leb (sort l). -Proof. auto using Sorted_StronglySorted, LocallySorted_sort. Qed. +Proof. auto using Sorted_StronglySorted, Sorted_sort. Qed. End Sort. @@ -259,7 +259,7 @@ Module NatOrder <: TotalLeBool. | _, 0 => false | S x', S y' => leb x' y' end. - Infix "<=?" := leb (at level 35). + Infix "<=?" := leb (at level 70, no associativity). Theorem leb_total : forall a1 a2, a1 <=? a2 \/ a2 <=? a1. Proof. induction a1; destruct a2; simpl; auto. @@ -269,4 +269,3 @@ End NatOrder. Module Import NatSort := Sort NatOrder. Example SimpleMergeExample := Eval compute in sort [5;3;6;1;8;6;0]. - diff --git a/theories/Structures/EqualitiesFacts.v b/theories/Structures/EqualitiesFacts.v index 6e8d9e4571..fe9794de8a 100644 --- a/theories/Structures/EqualitiesFacts.v +++ b/theories/Structures/EqualitiesFacts.v @@ -74,7 +74,7 @@ Module KeyDecidableType(D:DecidableType). Lemma InA_eqk_eqke {elt} p (m:list (key*elt)) : InA eqk p m -> exists q, eqk p q /\ InA eqke q m. Proof. - induction 1; firstorder. + induction 1; firstorder auto with crelations. Qed. Lemma InA_eqk {elt} p q (m:list (key*elt)) : diff --git a/theories/Structures/Orders.v b/theories/Structures/Orders.v index 6a0e7397eb..94938c1d4d 100644 --- a/theories/Structures/Orders.v +++ b/theories/Structures/Orders.v @@ -192,11 +192,11 @@ Module Type HasLtb (Import T:Typ). End HasLtb. Module Type LebNotation (T:Typ)(E:HasLeb T). - Infix "<=?" := E.leb (at level 35). + Infix "<=?" := E.leb (at level 70, no associativity). End LebNotation. Module Type LtbNotation (T:Typ)(E:HasLtb T). - Infix "<?" := E.ltb (at level 35). + Infix "<?" := E.ltb (at level 70, no associativity). End LtbNotation. Module Type LebSpec (T:Typ)(X:HasLe T)(Y:HasLeb T). diff --git a/theories/micromega/ZifyPow.v b/theories/micromega/ZifyPow.v new file mode 100644 index 0000000000..d208696c0f --- /dev/null +++ b/theories/micromega/ZifyPow.v @@ -0,0 +1 @@ +Require Export ZifyInst. diff --git a/theories/omega/Omega.v b/theories/omega/Omega.v index 9c2e8a9212..10a5aa47b3 100644 --- a/theories/omega/Omega.v +++ b/theories/omega/Omega.v @@ -19,6 +19,7 @@ Require Export ZArith_base. Require Export OmegaLemmas. Require Export PreOmega. +Require Import Lia. Declare ML Module "omega_plugin". @@ -28,28 +29,28 @@ Hint Resolve Z.le_refl Z.add_comm Z.add_assoc Z.mul_comm Z.mul_assoc Z.add_0_l Require Export Zhints. -Hint Extern 10 (_ = _ :>nat) => abstract omega: zarith. -Hint Extern 10 (_ <= _) => abstract omega: zarith. -Hint Extern 10 (_ < _) => abstract omega: zarith. -Hint Extern 10 (_ >= _) => abstract omega: zarith. -Hint Extern 10 (_ > _) => abstract omega: zarith. - -Hint Extern 10 (_ <> _ :>nat) => abstract omega: zarith. -Hint Extern 10 (~ _ <= _) => abstract omega: zarith. -Hint Extern 10 (~ _ < _) => abstract omega: zarith. -Hint Extern 10 (~ _ >= _) => abstract omega: zarith. -Hint Extern 10 (~ _ > _) => abstract omega: zarith. - -Hint Extern 10 (_ = _ :>Z) => abstract omega: zarith. -Hint Extern 10 (_ <= _)%Z => abstract omega: zarith. -Hint Extern 10 (_ < _)%Z => abstract omega: zarith. -Hint Extern 10 (_ >= _)%Z => abstract omega: zarith. -Hint Extern 10 (_ > _)%Z => abstract omega: zarith. - -Hint Extern 10 (_ <> _ :>Z) => abstract omega: zarith. -Hint Extern 10 (~ (_ <= _)%Z) => abstract omega: zarith. -Hint Extern 10 (~ (_ < _)%Z) => abstract omega: zarith. -Hint Extern 10 (~ (_ >= _)%Z) => abstract omega: zarith. -Hint Extern 10 (~ (_ > _)%Z) => abstract omega: zarith. - -Hint Extern 10 False => abstract omega: zarith. +Hint Extern 10 (_ = _ :>nat) => abstract lia: zarith. +Hint Extern 10 (_ <= _) => abstract lia: zarith. +Hint Extern 10 (_ < _) => abstract lia: zarith. +Hint Extern 10 (_ >= _) => abstract lia: zarith. +Hint Extern 10 (_ > _) => abstract lia: zarith. + +Hint Extern 10 (_ <> _ :>nat) => abstract lia: zarith. +Hint Extern 10 (~ _ <= _) => abstract lia: zarith. +Hint Extern 10 (~ _ < _) => abstract lia: zarith. +Hint Extern 10 (~ _ >= _) => abstract lia: zarith. +Hint Extern 10 (~ _ > _) => abstract lia: zarith. + +Hint Extern 10 (_ = _ :>Z) => abstract lia: zarith. +Hint Extern 10 (_ <= _)%Z => abstract lia: zarith. +Hint Extern 10 (_ < _)%Z => abstract lia: zarith. +Hint Extern 10 (_ >= _)%Z => abstract lia: zarith. +Hint Extern 10 (_ > _)%Z => abstract lia: zarith. + +Hint Extern 10 (_ <> _ :>Z) => abstract lia: zarith. +Hint Extern 10 (~ (_ <= _)%Z) => abstract lia: zarith. +Hint Extern 10 (~ (_ < _)%Z) => abstract lia: zarith. +Hint Extern 10 (~ (_ >= _)%Z) => abstract lia: zarith. +Hint Extern 10 (~ (_ > _)%Z) => abstract lia: zarith. + +Hint Extern 10 False => abstract lia: zarith. diff --git a/tools/coqdoc/output.ml b/tools/coqdoc/output.ml index d2b0078a7c..862715753d 100644 --- a/tools/coqdoc/output.ml +++ b/tools/coqdoc/output.ml @@ -42,7 +42,7 @@ let is_keyword = "Mutual"; "Parameter"; "Parameters"; "Print"; "Printing"; "All"; "Proof"; "Proof with"; "Qed"; "Record"; "Recursive"; "Remark"; "Require"; "Save"; "Scheme"; "Assumptions"; "Axioms"; "Universes"; "Induction"; "for"; "Sort"; "Section"; "Show"; "Structure"; "Syntactic"; "Syntax"; "Tactic"; "Theorem"; - "Search"; "SearchAbout"; "SearchHead"; "SearchPattern"; "SearchRewrite"; + "Search"; "SearchHead"; "SearchPattern"; "SearchRewrite"; "Set"; "Types"; "Undo"; "Unset"; "Variable"; "Variables"; "Context"; "Notation"; "Reserved Notation"; "Tactic Notation"; "Delimit"; "Bind"; "Open"; "Scope"; "Inline"; diff --git a/toplevel/ccompile.ml b/toplevel/ccompile.ml index d0d6b8b0a3..a7a9b77b56 100644 --- a/toplevel/ccompile.ml +++ b/toplevel/ccompile.ml @@ -92,6 +92,41 @@ let create_empty_file filename = let f = open_out filename in close_out f +let interp_set_option opt v old = + let open Goptions in + let err expect = + let opt = String.concat " " opt in + let got = v in (* avoid colliding with Pp.v *) + CErrors.user_err + Pp.(str "-set: " ++ str opt ++ + str" expects " ++ str expect ++ + str" but got " ++ str got) + in + match old with + | BoolValue _ -> + let v = match String.trim v with + | "true" -> true + | "false" | "" -> false + | _ -> err "a boolean" + in + BoolValue v + | IntValue _ -> + let v = String.trim v in + let v = match int_of_string_opt v with + | Some _ as v -> v + | None -> if v = "" then None else err "an int" + in + IntValue v + | StringValue _ -> StringValue v + | StringOptValue _ -> StringOptValue (Some v) + +let set_option = let open Goptions in function + | opt, OptionUnset -> unset_option_value_gen ~locality:OptLocal opt + | opt, OptionSet None -> set_bool_option_value_gen ~locality:OptLocal opt true + | opt, OptionSet (Some v) -> set_option_value ~locality:OptLocal (interp_set_option opt) opt v + +let set_options = List.iter set_option + (* Compile a vernac file *) let compile opts copts ~echo ~f_in ~f_out = let open Vernac.State in @@ -134,6 +169,7 @@ let compile opts copts ~echo ~f_in ~f_out = } in let state = { doc; sid; proof = None; time = opts.config.time } in let state = load_init_vernaculars opts ~state in + set_options opts.config.set_options; let ldir = Stm.get_ldir ~doc:state.doc in Aux_file.(start_aux_file ~aux_file:(aux_file_name_for long_f_dot_out) @@ -187,6 +223,7 @@ let compile opts copts ~echo ~f_in ~f_out = let state = { doc; sid; proof = None; time = opts.config.time } in let state = load_init_vernaculars opts ~state in + set_options opts.config.set_options; let ldir = Stm.get_ldir ~doc:state.doc in let state = Vernac.load_vernac ~echo ~check:false ~interactive:false ~state long_f_dot_in in let doc = Stm.finish ~doc:state.doc in diff --git a/toplevel/ccompile.mli b/toplevel/ccompile.mli index 8c154488d0..eb66dbaafc 100644 --- a/toplevel/ccompile.mli +++ b/toplevel/ccompile.mli @@ -17,3 +17,5 @@ val compile_files : Coqargs.t -> Coqcargs.t -> unit (** [do_vio opts] process [.vio] files in [opts] *) val do_vio : Coqargs.t -> Coqcargs.t -> unit + +val set_options : (Goptions.option_name * Coqargs.option_command) list -> unit diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml index 8d9b9411dd..a63cff3e6f 100644 --- a/toplevel/coqtop.ml +++ b/toplevel/coqtop.ml @@ -46,41 +46,6 @@ let print_memory_stat () = close_out oc with _ -> () -let interp_set_option opt v old = - let open Goptions in - let err expect = - let opt = String.concat " " opt in - let got = v in (* avoid colliding with Pp.v *) - CErrors.user_err - Pp.(str "-set: " ++ str opt ++ - str" expects " ++ str expect ++ - str" but got " ++ str got) - in - match old with - | BoolValue _ -> - let v = match String.trim v with - | "true" -> true - | "false" | "" -> false - | _ -> err "a boolean" - in - BoolValue v - | IntValue _ -> - let v = String.trim v in - let v = match int_of_string_opt v with - | Some _ as v -> v - | None -> if v = "" then None else err "an int" - in - IntValue v - | StringValue _ -> StringValue v - | StringOptValue _ -> StringOptValue (Some v) - -let set_option = let open Goptions in function - | opt, OptionUnset -> unset_option_value_gen ~locality:OptLocal opt - | opt, OptionSet None -> set_bool_option_value_gen ~locality:OptLocal opt true - | opt, OptionSet (Some v) -> set_option_value ~locality:OptLocal (interp_set_option opt) opt v - -let set_options = List.iter set_option - (******************************************************************************) (* Input/Output State *) (******************************************************************************) @@ -236,8 +201,6 @@ let init_execution opts custom_init = Global.set_allow_sprop opts.config.logic.allow_sprop; if opts.config.logic.cumulative_sprop then Global.make_sprop_cumulative (); - set_options opts.config.set_options; - (* Native output dir *) Nativelib.output_dir := opts.config.native_output_dir; Nativelib.include_dirs := opts.config.native_include_dirs; @@ -311,6 +274,7 @@ type run_mode = Interactive | Batch let init_toploop opts = let state = init_document opts in let state = Ccompile.load_init_vernaculars opts ~state in + Ccompile.set_options opts.config.set_options; state let coqtop_init run_mode ~opts = diff --git a/toplevel/usage.ml b/toplevel/usage.ml index 8fc1e03589..e69b21a195 100644 --- a/toplevel/usage.ml +++ b/toplevel/usage.ml @@ -41,7 +41,7 @@ let print_usage_common co command = \n -l f (idem)\ \n -load-vernac-source-verbose f load Coq file f.v (Load Verbose \"f\".)\ \n -lv f (idem)\ -\n -load-vernac-object lib, -r lib\ +\n -load-vernac-object lib\ \n load Coq library lib (Require lib)\ \n -rfrom root lib load Coq library lib (From root Require lib.)\ \n -require-import lib, -ri lib\ diff --git a/toplevel/vernac.ml b/toplevel/vernac.ml index 955630f40c..076796468f 100644 --- a/toplevel/vernac.ml +++ b/toplevel/vernac.ml @@ -100,7 +100,7 @@ let load_vernac_core ~echo ~check ~interactive ~state file = with | None -> input_cleanup (); - state, ids, Pcoq.Parsable.comment_state in_pa + state, ids, Pcoq.Parsable.comments in_pa | Some ast -> (* Printing of AST for -compile-verbose *) Option.iter (vernac_echo ?loc:ast.CAst.loc) in_echo; diff --git a/user-contrib/Ltac2/g_ltac2.mlg b/user-contrib/Ltac2/g_ltac2.mlg index 5e04959e9a..57d59fc2ef 100644 --- a/user-contrib/Ltac2/g_ltac2.mlg +++ b/user-contrib/Ltac2/g_ltac2.mlg @@ -826,12 +826,12 @@ END let () = -let open Extend in let open Tok in -let (++) r s = Next (r, s) in +let (++) r s = Pcoq.Rule.next r s in let rules = [ - Rule ( - Stop ++ Aentry test_dollar_ident ++ Atoken (PKEYWORD "$") ++ Aentry Prim.ident, + Pcoq.( + Production.make + (Rule.stop ++ Symbol.nterm test_dollar_ident ++ Symbol.token (PKEYWORD "$") ++ Symbol.nterm Prim.ident) begin fun id _ _ loc -> let id = Loc.tag ~loc id in let arg = Genarg.in_gen (Genarg.rawwit Tac2env.wit_ltac2_quotation) id in @@ -839,8 +839,9 @@ let rules = [ end ); - Rule ( - Stop ++ Aentry test_ampersand_ident ++ Atoken (PKEYWORD "&") ++ Aentry Prim.ident, + Pcoq.( + Production.make + (Rule.stop ++ Symbol.nterm test_ampersand_ident ++ Symbol.token (PKEYWORD "&") ++ Symbol.nterm Prim.ident) begin fun id _ _ loc -> let tac = Tac2quote.of_exact_hyp ~loc (CAst.make ~loc id) in let arg = Genarg.in_gen (Genarg.rawwit Tac2env.wit_ltac2_constr) tac in @@ -848,9 +849,10 @@ let rules = [ end ); - Rule ( - Stop ++ Atoken (PIDENT (Some "ltac2")) ++ Atoken (PKEYWORD ":") ++ - Atoken (PKEYWORD "(") ++ Aentry tac2expr ++ Atoken (PKEYWORD ")"), + Pcoq.( + Production.make + (Rule.stop ++ Symbol.token (PIDENT (Some "ltac2")) ++ Symbol.token (PKEYWORD ":") ++ + Symbol.token (PKEYWORD "(") ++ Symbol.nterm tac2expr ++ Symbol.token (PKEYWORD ")")) begin fun _ tac _ _ _ loc -> let arg = Genarg.in_gen (Genarg.rawwit Tac2env.wit_ltac2_constr) tac in CAst.make ~loc (CHole (None, Namegen.IntroAnonymous, Some arg)) @@ -859,7 +861,7 @@ let rules = [ ] in Hook.set Tac2entries.register_constr_quotations begin fun () -> - Pcoq.grammar_extend Pcoq.Constr.operconstr (Some (Gramlib.Gramext.Level "0"), [(None, None, rules)]) + Pcoq.grammar_extend Pcoq.Constr.operconstr {pos=Some (Gramlib.Gramext.Level "0"); data=[(None, None, rules)]} end } diff --git a/user-contrib/Ltac2/tac2core.ml b/user-contrib/Ltac2/tac2core.ml index 38b05bed6b..2ed854c9f7 100644 --- a/user-contrib/Ltac2/tac2core.ml +++ b/user-contrib/Ltac2/tac2core.ml @@ -1431,7 +1431,7 @@ let q_unit = CAst.make @@ CTacCst (AbsKn (Tuple 0)) let add_generic_scope s entry arg = let parse = function | [] -> - let scope = Extend.Aentry entry in + let scope = Pcoq.Symbol.nterm entry in let act x = CAst.make @@ CTacExt (arg, x) in Tac2entries.ScopeRule (scope, act) | arg -> scope_fail s arg @@ -1442,14 +1442,14 @@ open CAst let () = add_scope "keyword" begin function | [SexprStr {loc;v=s}] -> - let scope = Extend.Atoken (Tok.PKEYWORD s) in + let scope = Pcoq.Symbol.token (Tok.PKEYWORD s) in Tac2entries.ScopeRule (scope, (fun _ -> q_unit)) | arg -> scope_fail "keyword" arg end let () = add_scope "terminal" begin function | [SexprStr {loc;v=s}] -> - let scope = Extend.Atoken (CLexer.terminal s) in + let scope = Pcoq.Symbol.token (CLexer.terminal s) in Tac2entries.ScopeRule (scope, (fun _ -> q_unit)) | arg -> scope_fail "terminal" arg end @@ -1457,13 +1457,13 @@ end let () = add_scope "list0" begin function | [tok] -> let Tac2entries.ScopeRule (scope, act) = Tac2entries.parse_scope tok in - let scope = Extend.Alist0 scope in + let scope = Pcoq.Symbol.list0 scope in let act l = Tac2quote.of_list act l in Tac2entries.ScopeRule (scope, act) | [tok; SexprStr {v=str}] -> let Tac2entries.ScopeRule (scope, act) = Tac2entries.parse_scope tok in - let sep = Extend.Atoken (CLexer.terminal str) in - let scope = Extend.Alist0sep (scope, sep) in + let sep = Pcoq.Symbol.token (CLexer.terminal str) in + let scope = Pcoq.Symbol.list0sep scope sep false in let act l = Tac2quote.of_list act l in Tac2entries.ScopeRule (scope, act) | arg -> scope_fail "list0" arg @@ -1472,13 +1472,13 @@ end let () = add_scope "list1" begin function | [tok] -> let Tac2entries.ScopeRule (scope, act) = Tac2entries.parse_scope tok in - let scope = Extend.Alist1 scope in + let scope = Pcoq.Symbol.list1 scope in let act l = Tac2quote.of_list act l in Tac2entries.ScopeRule (scope, act) | [tok; SexprStr {v=str}] -> let Tac2entries.ScopeRule (scope, act) = Tac2entries.parse_scope tok in - let sep = Extend.Atoken (CLexer.terminal str) in - let scope = Extend.Alist1sep (scope, sep) in + let sep = Pcoq.Symbol.token (CLexer.terminal str) in + let scope = Pcoq.Symbol.list1sep scope sep false in let act l = Tac2quote.of_list act l in Tac2entries.ScopeRule (scope, act) | arg -> scope_fail "list1" arg @@ -1487,7 +1487,7 @@ end let () = add_scope "opt" begin function | [tok] -> let Tac2entries.ScopeRule (scope, act) = Tac2entries.parse_scope tok in - let scope = Extend.Aopt scope in + let scope = Pcoq.Symbol.opt scope in let act opt = match opt with | None -> CAst.make @@ CTacCst (AbsKn (Other Core.c_none)) @@ -1500,7 +1500,7 @@ end let () = add_scope "self" begin function | [] -> - let scope = Extend.Aself in + let scope = Pcoq.Symbol.self in let act tac = tac in Tac2entries.ScopeRule (scope, act) | arg -> scope_fail "self" arg @@ -1508,7 +1508,7 @@ end let () = add_scope "next" begin function | [] -> - let scope = Extend.Anext in + let scope = Pcoq.Symbol.next in let act tac = tac in Tac2entries.ScopeRule (scope, act) | arg -> scope_fail "next" arg @@ -1517,12 +1517,12 @@ end let () = add_scope "tactic" begin function | [] -> (* Default to level 5 parsing *) - let scope = Extend.Aentryl (tac2expr, "5") in + let scope = Pcoq.Symbol.nterml tac2expr "5" in let act tac = tac in Tac2entries.ScopeRule (scope, act) | [SexprInt {loc;v=n}] as arg -> let () = if n < 0 || n > 6 then scope_fail "tactic" arg in - let scope = Extend.Aentryl (tac2expr, string_of_int n) in + let scope = Pcoq.Symbol.nterml tac2expr (string_of_int n) in let act tac = tac in Tac2entries.ScopeRule (scope, act) | arg -> scope_fail "tactic" arg @@ -1543,12 +1543,12 @@ let () = add_scope "constr" (fun arg -> arg in let act e = Tac2quote.of_constr ~delimiters e in - Tac2entries.ScopeRule (Extend.Aentry Pcoq.Constr.constr, act) + Tac2entries.ScopeRule (Pcoq.Symbol.nterm Pcoq.Constr.constr, act) ) let add_expr_scope name entry f = add_scope name begin function - | [] -> Tac2entries.ScopeRule (Extend.Aentry entry, f) + | [] -> Tac2entries.ScopeRule (Pcoq.Symbol.nterm entry, f) | arg -> scope_fail name arg end @@ -1578,28 +1578,7 @@ let () = add_generic_scope "pattern" Pcoq.Constr.constr Tac2quote.wit_pattern (** seq scope, a bit hairy *) -open Extend -exception SelfSymbol - -let rec generalize_symbol : - type a tr s. (s, tr, a) Extend.symbol -> (s, Extend.norec, a) Extend.symbol = function -| Atoken tok -> Atoken tok -| Alist1 e -> Alist1 (generalize_symbol e) -| Alist1sep (e, sep) -> - let e = generalize_symbol e in - let sep = generalize_symbol sep in - Alist1sep (e, sep) -| Alist0 e -> Alist0 (generalize_symbol e) -| Alist0sep (e, sep) -> - let e = generalize_symbol e in - let sep = generalize_symbol sep in - Alist0sep (e, sep) -| Aopt e -> Aopt (generalize_symbol e) -| Aself -> raise SelfSymbol -| Anext -> raise SelfSymbol -| Aentry e -> Aentry e -| Aentryl (e, l) -> Aentryl (e, l) -| Arules r -> Arules r +open Pcoq type _ converter = | CvNil : (Loc.t -> raw_tacexpr) converter @@ -1611,16 +1590,21 @@ let rec apply : type a. a converter -> raw_tacexpr list -> a = function | CvCns (c, Some f) -> fun accu x -> apply c (f x :: accu) type seqrule = -| Seqrule : (Tac2expr.raw_tacexpr, Extend.norec, 'act, Loc.t -> raw_tacexpr) rule * 'act converter -> seqrule +| Seqrule : (Tac2expr.raw_tacexpr, Gramlib.Grammar.norec, 'act, Loc.t -> raw_tacexpr) Rule.t * 'act converter -> seqrule let rec make_seq_rule = function | [] -> - Seqrule (Stop, CvNil) + Seqrule (Pcoq.Rule.stop, CvNil) | tok :: rem -> let Tac2entries.ScopeRule (scope, f) = Tac2entries.parse_scope tok in - let scope = generalize_symbol scope in + let scope = + match Pcoq.generalize_symbol scope with + | None -> + CErrors.user_err (str "Recursive symbols (self / next) are not allowed in local rules") + | Some scope -> scope + in let Seqrule (r, c) = make_seq_rule rem in - let r = NextNoRec (r, scope) in + let r = Pcoq.Rule.next_norec r scope in let f = match tok with | SexprStr _ -> None (* Leave out mere strings *) | _ -> Some f @@ -1629,11 +1613,8 @@ let rec make_seq_rule = function let () = add_scope "seq" begin fun toks -> let scope = - try - let Seqrule (r, c) = make_seq_rule (List.rev toks) in - Arules [Rules (r, apply c [])] - with SelfSymbol -> - CErrors.user_err (str "Recursive symbols (self / next) are not allowed in local rules") + let Seqrule (r, c) = make_seq_rule (List.rev toks) in + Pcoq.(Symbol.rules [Rules.make r (apply c [])]) in Tac2entries.ScopeRule (scope, (fun e -> e)) end diff --git a/user-contrib/Ltac2/tac2entries.ml b/user-contrib/Ltac2/tac2entries.ml index e9945794d3..ebc63ddd01 100644 --- a/user-contrib/Ltac2/tac2entries.ml +++ b/user-contrib/Ltac2/tac2entries.ml @@ -558,7 +558,7 @@ type 'a token = | TacNonTerm of Name.t * 'a type scope_rule = -| ScopeRule : (raw_tacexpr, _, 'a) Extend.symbol * ('a -> raw_tacexpr) -> scope_rule +| ScopeRule : (raw_tacexpr, _, 'a) Pcoq.Symbol.t * ('a -> raw_tacexpr) -> scope_rule type scope_interpretation = sexpr list -> scope_rule @@ -583,7 +583,7 @@ let parse_scope = function CErrors.user_err ?loc (str "Unknown scope" ++ spc () ++ Names.Id.print id) | SexprStr {v=str} -> let v_unit = CAst.make @@ CTacCst (AbsKn (Tuple 0)) in - ScopeRule (Extend.Atoken (Tok.PIDENT (Some str)), (fun _ -> v_unit)) + ScopeRule (Pcoq.Symbol.token (Tok.PIDENT (Some str)), (fun _ -> v_unit)) | tok -> let loc = loc_of_token tok in CErrors.user_err ?loc (str "Invalid parsing token") @@ -611,19 +611,19 @@ type synext = { type krule = | KRule : - (raw_tacexpr, _, 'act, Loc.t -> raw_tacexpr) Extend.rule * + (raw_tacexpr, _, 'act, Loc.t -> raw_tacexpr) Pcoq.Rule.t * ((Loc.t -> (Name.t * raw_tacexpr) list -> raw_tacexpr) -> 'act) -> krule let rec get_rule (tok : scope_rule token list) : krule = match tok with -| [] -> KRule (Extend.Stop, fun k loc -> k loc []) +| [] -> KRule (Pcoq.Rule.stop, fun k loc -> k loc []) | TacNonTerm (na, ScopeRule (scope, inj)) :: tok -> let KRule (rule, act) = get_rule tok in - let rule = Extend.Next (rule, scope) in + let rule = Pcoq.Rule.next rule scope in let act k e = act (fun loc acc -> k loc ((na, inj e) :: acc)) in KRule (rule, act) | TacTerm t :: tok -> let KRule (rule, act) = get_rule tok in - let rule = Extend.Next (rule, Extend.Atoken (CLexer.terminal t)) in + let rule = Pcoq.(Rule.next rule (Symbol.token (CLexer.terminal t))) in let act k _ = act k in KRule (rule, act) @@ -637,13 +637,13 @@ let perform_notation syn st = let bnd = List.map map args in CAst.make ~loc @@ CTacLet (false, bnd, syn.synext_exp) in - let rule = Extend.Rule (rule, act mk) in + let rule = Pcoq.Production.make rule (act mk) in let lev = match syn.synext_lev with | None -> None | Some lev -> Some (string_of_int lev) in let rule = (lev, None, [rule]) in - ([Pcoq.ExtendRule (Pltac.tac2expr, (None, [rule]))], st) + ([Pcoq.ExtendRule (Pltac.tac2expr, {Pcoq.pos=None; data=[rule]})], st) let ltac2_notation = Pcoq.create_grammar_command "ltac2-notation" perform_notation diff --git a/user-contrib/Ltac2/tac2entries.mli b/user-contrib/Ltac2/tac2entries.mli index fed43a4dd5..edad118dc9 100644 --- a/user-contrib/Ltac2/tac2entries.mli +++ b/user-contrib/Ltac2/tac2entries.mli @@ -36,7 +36,7 @@ val perform_eval : pstate:Proof_global.t option -> raw_tacexpr -> unit (** {5 Notations} *) type scope_rule = -| ScopeRule : (raw_tacexpr, _, 'a) Extend.symbol * ('a -> raw_tacexpr) -> scope_rule +| ScopeRule : (raw_tacexpr, _, 'a) Pcoq.Symbol.t * ('a -> raw_tacexpr) -> scope_rule type scope_interpretation = sexpr list -> scope_rule diff --git a/vernac/auto_ind_decl.ml b/vernac/auto_ind_decl.ml index 9ed371bcfb..0c9b9c7255 100644 --- a/vernac/auto_ind_decl.ml +++ b/vernac/auto_ind_decl.ml @@ -691,10 +691,10 @@ let make_bl_scheme mode mind = let lnonparrec,lnamesparrec = (* TODO subst *) context_chop (nparams-nparrec) mib.mind_params_ctxt in let bl_goal, eff = compute_bl_goal ind lnamesparrec nparrec in - let ctx = UState.make ~lbound:(Global.universes_lbound ()) (Global.universes ()) in + let uctx = UState.make ~lbound:(Global.universes_lbound ()) (Global.universes ()) in let side_eff = side_effect_of_mode mode in let bl_goal = EConstr.of_constr bl_goal in - let (ans, _, ctx) = Pfedit.build_by_tactic ~poly:false ~side_eff (Global.env()) ctx bl_goal + let (ans, _, _, ctx) = Pfedit.build_by_tactic ~poly:false ~side_eff (Global.env()) ~uctx ~typ:bl_goal (compute_bl_tact mode (!bl_scheme_kind_aux()) (ind, EConstr.EInstance.empty) lnamesparrec nparrec) in ([|ans|], ctx), eff @@ -821,10 +821,10 @@ let make_lb_scheme mode mind = let lnonparrec,lnamesparrec = context_chop (nparams-nparrec) mib.mind_params_ctxt in let lb_goal, eff = compute_lb_goal ind lnamesparrec nparrec in - let ctx = UState.make ~lbound:(Global.universes_lbound ()) (Global.universes ()) in + let uctx = UState.make ~lbound:(Global.universes_lbound ()) (Global.universes ()) in let side_eff = side_effect_of_mode mode in let lb_goal = EConstr.of_constr lb_goal in - let (ans, _, ctx) = Pfedit.build_by_tactic ~poly:false ~side_eff (Global.env()) ctx lb_goal + let (ans, _, _, ctx) = Pfedit.build_by_tactic ~poly:false ~side_eff (Global.env()) ~uctx ~typ:lb_goal (compute_lb_tact mode (!lb_scheme_kind_aux()) ind lnamesparrec nparrec) in ([|ans|], ctx), eff @@ -997,13 +997,13 @@ let make_eq_decidability mode mind = let nparams = mib.mind_nparams in let nparrec = mib.mind_nparams_rec in let u = Univ.Instance.empty in - let ctx = UState.make ~lbound:(Global.universes_lbound ()) (Global.universes ()) in + let uctx = UState.make ~lbound:(Global.universes_lbound ()) (Global.universes ()) in let lnonparrec,lnamesparrec = context_chop (nparams-nparrec) mib.mind_params_ctxt in let side_eff = side_effect_of_mode mode in - let (ans, _, ctx) = Pfedit.build_by_tactic ~poly:false ~side_eff (Global.env()) ctx - (EConstr.of_constr (compute_dec_goal (ind,u) lnamesparrec nparrec)) - (compute_dec_tact ind lnamesparrec nparrec) + let (ans, _, _, ctx) = Pfedit.build_by_tactic ~poly:false ~side_eff (Global.env()) ~uctx + ~typ:(EConstr.of_constr (compute_dec_goal (ind,u) lnamesparrec nparrec)) + (compute_dec_tact ind lnamesparrec nparrec) in ([|ans|], ctx), Evd.empty_side_effects diff --git a/vernac/classes.ml b/vernac/classes.ml index b1f7b2a0c3..6e929de581 100644 --- a/vernac/classes.ml +++ b/vernac/classes.ml @@ -304,54 +304,52 @@ let id_of_class cl = mip.(0).Declarations.mind_typename | _ -> assert false -let instance_hook info global imps ?hook cst = - Impargs.maybe_declare_manual_implicits false cst imps; +let instance_hook info global ?hook cst = let info = intern_info info in let env = Global.env () in let sigma = Evd.from_env env in declare_instance env sigma (Some info) (not global) cst; (match hook with Some h -> h cst | None -> ()) -let declare_instance_constant info global imps ?hook name decl poly sigma term termtype = +let declare_instance_constant info global impargs ?hook name udecl poly sigma term termtype = let kind = Decls.(IsDefinition Instance) in - let sigma, entry = DeclareDef.prepare_definition - ~allow_evars:false ~poly sigma decl ~types:(Some termtype) ~body:term in - let kn = Declare.declare_constant ~name ~kind (Declare.DefinitionEntry entry) in - Declare.definition_message name; - DeclareUniv.declare_univ_binders (GlobRef.ConstRef kn) (Evd.universe_binders sigma); - instance_hook info global imps ?hook (GlobRef.ConstRef kn) - -let do_declare_instance sigma ~global ~poly k u ctx ctx' pri decl imps subst name = + let scope = DeclareDef.Global Declare.ImportDefaultBehavior in + let kn = DeclareDef.declare_definition ~name ~kind ~scope ~impargs + ~opaque:false ~poly sigma ~udecl ~types:(Some termtype) ~body:term in + instance_hook info global ?hook kn + +let do_declare_instance sigma ~global ~poly k u ctx ctx' pri udecl impargs subst name = let subst = List.fold_left2 (fun subst' s decl -> if is_local_assum decl then s :: subst' else subst') [] subst (snd k.cl_context) in let (_, ty_constr) = instance_constructor (k,u) subst in let termtype = it_mkProd_or_LetIn ty_constr (ctx' @ ctx) in - let sigma, entry = DeclareDef.prepare_parameter ~allow_evars:false ~poly sigma decl termtype in + let sigma, entry = DeclareDef.prepare_parameter ~poly sigma ~udecl ~types:termtype in let cst = Declare.declare_constant ~name ~kind:Decls.(IsAssumption Logical) (Declare.ParameterEntry entry) in DeclareUniv.declare_univ_binders (GlobRef.ConstRef cst) (Evd.universe_binders sigma); - instance_hook pri global imps (GlobRef.ConstRef cst) + let cst = (GlobRef.ConstRef cst) in + Impargs.maybe_declare_manual_implicits false cst impargs; + instance_hook pri global cst -let declare_instance_program env sigma ~global ~poly name pri imps univdecl term termtype = +let declare_instance_program env sigma ~global ~poly name pri impargs udecl term termtype = let hook { DeclareDef.Hook.S.scope; dref; _ } = let cst = match dref with GlobRef.ConstRef kn -> kn | _ -> assert false in - Impargs.declare_manual_implicits false dref imps; let pri = intern_info pri in let env = Global.env () in let sigma = Evd.from_env env in declare_instance env sigma (Some pri) (not global) (GlobRef.ConstRef cst) in - let obls, _, term, typ = Obligations.eterm_obligations env name sigma 0 term termtype in + let obls, _, term, typ = RetrieveObl.retrieve_obligations env name sigma 0 term termtype in let hook = DeclareDef.Hook.make hook in - let ctx = Evd.evar_universe_context sigma in + let uctx = Evd.evar_universe_context sigma in let scope, kind = DeclareDef.Global Declare.ImportDefaultBehavior, Decls.Instance in let _ : DeclareObl.progress = - Obligations.add_definition ~name ~term ~univdecl ~scope ~poly ~kind ~hook typ ctx obls + Obligations.add_definition ~name ~term ~udecl ~scope ~poly ~kind ~hook ~impargs ~uctx typ obls in () -let declare_instance_open sigma ?hook ~tac ~global ~poly id pri imps udecl ids term termtype = +let declare_instance_open sigma ?hook ~tac ~global ~poly id pri impargs udecl ids term termtype = (* spiwack: it is hard to reorder the actions to do the pretyping after the proof has opened. As a consequence, we use the low-level primitives to code @@ -359,12 +357,12 @@ let declare_instance_open sigma ?hook ~tac ~global ~poly id pri imps udecl ids t let gls = List.rev (Evd.future_goals sigma) in let sigma = Evd.reset_future_goals sigma in let kind = Decls.(IsDefinition Instance) in - let hook = DeclareDef.Hook.(make (fun { S.dref ; _ } -> instance_hook pri global imps ?hook dref)) in + let hook = DeclareDef.Hook.(make (fun { S.dref ; _ } -> instance_hook pri global ?hook dref)) in let info = Lemmas.Info.make ~hook ~kind () in (* XXX: We need to normalize the type, otherwise Admitted / Qed will fails! This is due to a bug in proof_global :( *) let termtype = Evarutil.nf_evar sigma termtype in - let lemma = Lemmas.start_lemma ~name:id ~poly ~udecl ~info sigma termtype in + let lemma = Lemmas.start_lemma ~name:id ~poly ~udecl ~info ~impargs sigma termtype in (* spiwack: I don't know what to do with the status here. *) let lemma = match term with diff --git a/vernac/comAssumption.ml b/vernac/comAssumption.ml index 8eff26bae5..47ae03e0a3 100644 --- a/vernac/comAssumption.ml +++ b/vernac/comAssumption.ml @@ -203,8 +203,12 @@ let context_insection sigma ~poly ctx = else Monomorphic_entry Univ.ContextSet.empty in let entry = Declare.definition_entry ~univs ~types:t b in - let _ : GlobRef.t = DeclareDef.declare_definition ~name ~scope:DeclareDef.Discharge - ~kind:Decls.(IsDefinition Definition) UnivNames.empty_binders entry [] + (* XXX Fixme: Use DeclareDef.prepare_definition *) + let uctx = Evd.evar_universe_context sigma in + let kind = Decls.(IsDefinition Definition) in + let _ : GlobRef.t = + DeclareDef.declare_entry ~name ~scope:DeclareDef.Discharge + ~kind ~impargs:[] ~uctx entry in () in diff --git a/vernac/comDefinition.ml b/vernac/comDefinition.ml index 8a0d0c9d81..8a91e9e63f 100644 --- a/vernac/comDefinition.ml +++ b/vernac/comDefinition.ml @@ -12,7 +12,6 @@ open Pp open Util open Redexpr open Constrintern -open Pretyping (* Commands of the interface: Constant definitions *) @@ -40,10 +39,50 @@ let check_imps ~impsty ~impsbody = | [], [] -> () in aux impsty impsbody +let protect_pattern_in_binder bl c ctypopt = + (* We turn "Definition d binders := body : typ" into *) + (* "Definition d := fun binders => body:type" *) + (* This is a hack while waiting for LocalPattern in regular environments *) + if List.exists (function Constrexpr.CLocalPattern _ -> true | _ -> false) bl + then + let t = match ctypopt with + | None -> CAst.make ?loc:c.CAst.loc (Constrexpr.CHole (None,Namegen.IntroAnonymous,None)) + | Some t -> t in + let loc = Loc.merge_opt c.CAst.loc t.CAst.loc in + let c = CAst.make ?loc @@ Constrexpr.CCast (c, Glob_term.CastConv t) in + let loc = match List.hd bl with + | Constrexpr.CLocalAssum (a::_,_,_) | Constrexpr.CLocalDef (a,_,_) -> a.CAst.loc + | Constrexpr.CLocalPattern {CAst.loc} -> loc + | Constrexpr.CLocalAssum ([],_,_) -> assert false in + let apply_under_binders f env evd c = + let rec aux env evd c = + let open Constr in + let open EConstr in + let open Context.Rel.Declaration in + match kind evd c with + | Lambda (x,t,c) -> + let evd,c = aux (push_rel (LocalAssum (x,t)) env) evd c in + evd, mkLambda (x,t,c) + | LetIn (x,b,t,c) -> + let evd,c = aux (push_rel (LocalDef (x,b,t)) env) evd c in + evd, mkLetIn (x,t,b,c) + | Case (ci,p,a,bl) -> + let evd,bl = Array.fold_left_map (aux env) evd bl in + evd, mkCase (ci,p,a,bl) + | Cast (c,_,_) -> f env evd c (* we remove the cast we had set *) + (* This last case may happen when reaching the proof of an + impossible case, as when pattern-matching on a vector of length 1 *) + | _ -> (evd,c) in + aux env evd c in + ([], Constrexpr_ops.mkLambdaCN ?loc:(Loc.merge_opt loc c.CAst.loc) bl c, None, apply_under_binders) + else + (bl, c, ctypopt, fun f env evd c -> f env evd c) + let interp_definition ~program_mode pl bl ~poly red_option c ctypopt = let env = Global.env() in (* Explicitly bound universes and constraints *) let evd, udecl = Constrexpr_ops.interp_univ_decl_opt env pl in + let (bl, c, ctypopt, apply_under_binders) = protect_pattern_in_binder bl c ctypopt in (* Build the parameters *) let evd, (impls, ((env_bl, ctx), imps1)) = interp_context_evars ~program_mode env evd bl in (* Build the type *) @@ -63,46 +102,31 @@ let interp_definition ~program_mode pl bl ~poly red_option c ctypopt = evd, c, imps1@impsty, Some ty in (* Do the reduction *) - let evd, c = red_constant_body red_option env_bl evd c in + let evd, c = apply_under_binders (red_constant_body red_option) env_bl evd c in (* Declare the definition *) let c = EConstr.it_mkLambda_or_LetIn c ctx in let tyopt = Option.map (fun ty -> EConstr.it_mkProd_or_LetIn ty ctx) tyopt in + (c, tyopt), evd, udecl, imps - let evd, ce = DeclareDef.prepare_definition ~allow_evars:program_mode - ~opaque:false ~poly evd udecl ~types:tyopt ~body:c in - - (ce, evd, udecl, imps) - -let check_definition ~program_mode (ce, evd, _, imps) = - let env = Global.env () in - check_evars_are_solved ~program_mode env evd; - ce +let do_definition ?hook ~name ~scope ~poly ~kind udecl bl red_option c ctypopt = + let program_mode = false in + let (body, types), evd, udecl, impargs = + interp_definition ~program_mode udecl bl ~poly red_option c ctypopt + in + let kind = Decls.IsDefinition kind in + let _ : Names.GlobRef.t = + DeclareDef.declare_definition ~name ~scope ~kind ?hook ~impargs + ~opaque:false ~poly evd ~udecl ~types ~body + in () -let do_definition ~program_mode ?hook ~name ~scope ~poly ~kind univdecl bl red_option c ctypopt = - let (ce, evd, univdecl, imps as def) = - interp_definition ~program_mode univdecl bl ~poly red_option c ctypopt +let do_definition_program ?hook ~name ~scope ~poly ~kind udecl bl red_option c ctypopt = + let program_mode = true in + let (body, types), evd, udecl, impargs = + interp_definition ~program_mode udecl bl ~poly red_option c ctypopt in - if program_mode then - let env = Global.env () in - let (c,ctx), sideff = Future.force ce.Declare.proof_entry_body in - assert(Safe_typing.empty_private_constants = sideff.Evd.seff_private); - assert(Univ.ContextSet.is_empty ctx); - Obligations.check_evars env evd; - let c = EConstr.of_constr c in - let typ = match ce.Declare.proof_entry_type with - | Some t -> EConstr.of_constr t - | None -> Retyping.get_type_of env evd c - in - let obls, _, c, cty = - Obligations.eterm_obligations env name evd 0 c typ - in - let ctx = Evd.evar_universe_context evd in - ignore(Obligations.add_definition - ~name ~term:c cty ctx ~univdecl ~implicits:imps ~scope ~poly ~kind ?hook obls) - else - let ce = check_definition ~program_mode def in - let uctx = Evd.evar_universe_context evd in - let hook_data = Option.map (fun hook -> hook, uctx, []) hook in - let kind = Decls.IsDefinition kind in - ignore(DeclareDef.declare_definition ~name ~scope ~kind ?hook_data (Evd.universe_binders evd) ce imps) + let term, ty, uctx, obls = DeclareDef.prepare_obligation ~name ~poly ~body ~types ~udecl evd in + let _ : DeclareObl.progress = + Obligations.add_definition + ~name ~term ty ~uctx ~udecl ~impargs ~scope ~poly ~kind ?hook obls + in () diff --git a/vernac/comDefinition.mli b/vernac/comDefinition.mli index 6c6da8952e..337da22018 100644 --- a/vernac/comDefinition.mli +++ b/vernac/comDefinition.mli @@ -15,8 +15,7 @@ open Constrexpr (** {6 Definitions/Let} *) val do_definition - : program_mode:bool - -> ?hook:DeclareDef.Hook.t + : ?hook:DeclareDef.Hook.t -> name:Id.t -> scope:DeclareDef.locality -> poly:bool @@ -28,18 +27,15 @@ val do_definition -> constr_expr option -> unit -(************************************************************************) -(** Internal API *) -(************************************************************************) - -(** Not used anywhere. *) -val interp_definition - : program_mode:bool +val do_definition_program + : ?hook:DeclareDef.Hook.t + -> name:Id.t + -> scope:DeclareDef.locality + -> poly:bool + -> kind:Decls.definition_object_kind -> universe_decl_expr option -> local_binder_expr list - -> poly:bool -> red_expr option -> constr_expr -> constr_expr option - -> Evd.side_effects Declare.proof_entry * - Evd.evar_map * UState.universe_decl * Impargs.manual_implicits + -> unit diff --git a/vernac/comFixpoint.ml b/vernac/comFixpoint.ml index 8c050b800a..cbf0affc12 100644 --- a/vernac/comFixpoint.ml +++ b/vernac/comFixpoint.ml @@ -9,22 +9,9 @@ (************************************************************************) open Pp -open CErrors open Util -open Constr -open Context -open Vars -open Termops -open Declare open Names -open Constrexpr -open Constrexpr_ops open Constrintern -open Pretyping -open Evarutil -open Evarconv - -module RelDecl = Context.Rel.Declaration (* 3c| Fixpoints and co-fixpoints *) @@ -99,7 +86,7 @@ let check_mutuality env evd isfix fixl = let names = List.map fst fixl in let preorder = List.map (fun (id,def) -> - (id, List.filter (fun id' -> not (Id.equal id id') && occur_var env evd id' def) names)) + (id, List.filter (fun id' -> not (Id.equal id id') && Termops.occur_var env evd id' def) names)) fixl in let po = partial_order Id.equal preorder in match List.filter (function (_,Inr _) -> true | _ -> false) po with @@ -110,13 +97,13 @@ let check_mutuality env evd isfix fixl = let interp_fix_context ~program_mode ~cofix env sigma fix = let before, after = if not cofix - then split_at_annot fix.Vernacexpr.binders fix.Vernacexpr.rec_order + then Constrexpr_ops.split_at_annot fix.Vernacexpr.binders fix.Vernacexpr.rec_order else [], fix.Vernacexpr.binders in let sigma, (impl_env, ((env', ctx), imps)) = interp_context_evars ~program_mode env sigma before in let sigma, (impl_env', ((env'', ctx'), imps')) = interp_context_evars ~program_mode ~impl_env ~shift:(Context.Rel.nhyps ctx) env' sigma after in - let annot = Option.map (fun _ -> List.length (assums_of_rel_context ctx)) fix.Vernacexpr.rec_order in + let annot = Option.map (fun _ -> List.length (Termops.assums_of_rel_context ctx)) fix.Vernacexpr.rec_order in sigma, ((env'', ctx' @ ctx), (impl_env',imps @ imps'), annot) let interp_fix_ccl ~program_mode sigma impls (env,_) fix = @@ -134,8 +121,8 @@ let interp_fix_body ~program_mode env_rec sigma impls (_,ctx) fix ccl = let build_fix_type (_,ctx) ccl = EConstr.it_mkProd_or_LetIn ccl ctx let prepare_recursive_declaration fixnames fixrs fixtypes fixdefs = - let defs = List.map (subst_vars (List.rev fixnames)) fixdefs in - let names = List.map2 (fun id r -> make_annot (Name id) r) fixnames fixrs in + let defs = List.map (Vars.subst_vars (List.rev fixnames)) fixdefs in + let names = List.map2 (fun id r -> Context.make_annot (Name id) r) fixnames fixrs in (Array.of_list names, Array.of_list fixtypes, Array.of_list defs) (* Jump over let-bindings. *) @@ -153,8 +140,8 @@ let compute_possible_guardness_evidences (ctx,_,recindex) = fixpoints ?) *) List.interval 0 (Context.Rel.nhyps ctx - 1) -type recursive_preentry = - Id.t list * Sorts.relevance list * constr option list * types list +type ('constr, 'types) recursive_preentry = + Id.t list * Sorts.relevance list * 'constr option list * 'types list (* Wellfounded definition *) @@ -177,9 +164,9 @@ let interp_recursive ~program_mode ~cofix (fixl : 'a Vernacexpr.fix_expr_gen lis let open UState in let lsu = ls.univdecl_instance and usu = us.univdecl_instance in if not (CList.for_all2eq (fun x y -> Id.equal x.CAst.v y.CAst.v) lsu usu) then - user_err Pp.(str "(co)-recursive definitions should all have the same universe binders"); + CErrors.user_err Pp.(str "(co)-recursive definitions should all have the same universe binders"); Some us) fixl None in - let sigma, decl = interp_univ_decl_opt env all_universes in + let sigma, decl = Constrexpr_ops.interp_univ_decl_opt env all_universes in let sigma, (fixctxs, fiximppairs, fixannots) = on_snd List.split3 @@ List.fold_left_map (fun sigma -> interp_fix_context ~program_mode env sigma ~cofix) sigma fixl in @@ -188,7 +175,7 @@ let interp_recursive ~program_mode ~cofix (fixl : 'a Vernacexpr.fix_expr_gen lis on_snd List.split3 @@ List.fold_left3_map (interp_fix_ccl ~program_mode) sigma fixctximpenvs fixctxs fixl in let fixtypes = List.map2 build_fix_type fixctxs fixccls in - let fixtypes = List.map (fun c -> nf_evar sigma c) fixtypes in + let fixtypes = List.map (fun c -> Evarutil.nf_evar sigma c) fixtypes in let fiximps = List.map3 (fun ctximps cclimps (_,ctx) -> ctximps@cclimps) fixctximps fixcclimps fixctxs in @@ -204,8 +191,8 @@ let interp_recursive ~program_mode ~cofix (fixl : 'a Vernacexpr.fix_expr_gen lis Typing.solve_evars env sigma app with e when CErrors.noncritical e -> sigma, t in - sigma, LocalAssum (make_annot id Sorts.Relevant,fixprot) :: env' - else sigma, LocalAssum (make_annot id Sorts.Relevant,t) :: env') + sigma, LocalAssum (Context.make_annot id Sorts.Relevant,fixprot) :: env' + else sigma, LocalAssum (Context.make_annot id Sorts.Relevant,t) :: env') (sigma,[]) fixnames fixtypes in let env_rec = push_named_context rec_sign env in @@ -224,7 +211,7 @@ let interp_recursive ~program_mode ~cofix (fixl : 'a Vernacexpr.fix_expr_gen lis () in (* Instantiate evars and check all are resolved *) - let sigma = solve_unif_constraints_with_heuristics env_rec sigma in + let sigma = Evarconv.solve_unif_constraints_with_heuristics env_rec sigma in let sigma = Evd.minimize_universes sigma in let fixctxs = List.map (fun (_,ctx) -> ctx) fixctxs in @@ -238,85 +225,77 @@ let check_recursive isfix env evd (fixnames,_,fixdefs,_) = end let ground_fixpoint env evd (fixnames,fixrs,fixdefs,fixtypes) = - check_evars_are_solved ~program_mode:false env evd; + Pretyping.check_evars_are_solved ~program_mode:false env evd; let fixdefs = List.map (fun c -> Option.map EConstr.(to_constr evd) c) fixdefs in let fixtypes = List.map EConstr.(to_constr evd) fixtypes in Evd.evar_universe_context evd, (fixnames,fixrs,fixdefs,fixtypes) -let interp_fixpoint ~cofix l = +(* XXX: Unify with interp_recursive *) +let interp_fixpoint ~cofix l : + ( (Constr.t, Constr.types) recursive_preentry * + UState.universe_decl * UState.t * + (EConstr.rel_context * Impargs.manual_implicits * int option) list) = let (env,_,pl,evd),fix,info = interp_recursive ~program_mode:false ~cofix l in check_recursive true env evd fix; let uctx,fix = ground_fixpoint env evd fix in (fix,pl,uctx,info) -let declare_fixpoint_interactive_generic ?indexes ~scope ~poly ((fixnames,_fixrs,fixdefs,fixtypes),udecl,ctx,fiximps) ntns = - let fix_kind, cofix, indexes = match indexes with - | Some indexes -> Decls.Fixpoint, false, indexes - | None -> Decls.CoFixpoint, true, [] +let build_recthms ~indexes fixnames fixtypes fiximps = + let fix_kind, cofix = match indexes with + | Some indexes -> Decls.Fixpoint, false + | None -> Decls.CoFixpoint, true in let thms = List.map3 (fun name typ (ctx,impargs,_) -> - { Lemmas.Recthm.name; typ - ; args = List.map RelDecl.get_name ctx; impargs}) - fixnames fixtypes fiximps in - let init_tac = - Some (List.map (Option.cata (EConstr.of_constr %> Tactics.exact_no_check) Tacticals.New.tclIDTAC) fixdefs) in + { DeclareDef.Recthm.name + ; typ + ; args = List.map Context.Rel.Declaration.get_name ctx + ; impargs}) + fixnames fixtypes fiximps + in + fix_kind, cofix, thms + +let declare_fixpoint_interactive_generic ?indexes ~scope ~poly ((fixnames,_fixrs,fixdefs,fixtypes),udecl,ctx,fiximps) ntns = + let fix_kind, cofix, thms = build_recthms ~indexes fixnames fixtypes fiximps in + let indexes = Option.default [] indexes in + let init_terms = Some fixdefs in let evd = Evd.from_ctx ctx in let lemma = Lemmas.start_lemma_with_initialization ~poly ~scope ~kind:(Decls.IsDefinition fix_kind) ~udecl - evd (Some(cofix,indexes,init_tac)) thms None in + evd (Some(cofix,indexes,init_terms)) thms None in (* Declare notations *) List.iter (Metasyntax.add_notation_interpretation (Global.env())) ntns; lemma -let declare_fixpoint_generic ?indexes ~scope ~poly ((fixnames,fixrs,fixdefs,fixtypes),pl,ctx,fiximps) ntns = - let indexes, cofix, fix_kind = - match indexes with - | Some indexes -> indexes, false, Decls.(IsDefinition Fixpoint) - | None -> [], true, Decls.(IsDefinition CoFixpoint) - in +let declare_fixpoint_generic ?indexes ~scope ~poly ((fixnames,fixrs,fixdefs,fixtypes),udecl,uctx,fiximps) ntns = (* We shortcut the proof process *) + let fix_kind, cofix, fixitems = build_recthms ~indexes fixnames fixtypes fiximps in let fixdefs = List.map Option.get fixdefs in - let fixdecls = prepare_recursive_declaration fixnames fixrs fixtypes fixdefs in - let vars, fixdecls, gidx = - if not cofix then - let env = Global.env() in - let indexes = search_guard env indexes fixdecls in - let vars = Vars.universes_of_constr (mkFix ((indexes,0),fixdecls)) in - let fixdecls = List.map_i (fun i _ -> mkFix ((indexes,i),fixdecls)) 0 fixnames in - vars, fixdecls, Some indexes - else (* cofix *) - let fixdecls = List.map_i (fun i _ -> mkCoFix (i,fixdecls)) 0 fixnames in - let vars = Vars.universes_of_constr (List.hd fixdecls) in - vars, fixdecls, None - in - let fiximps = List.map (fun (n,r,p) -> r) fiximps in - let evd = Evd.from_ctx ctx in - let evd = Evd.restrict_universe_context evd vars in - let ctx = Evd.check_univ_decl ~poly evd pl in - let udecl = Evd.universe_binders evd in + let rec_declaration = prepare_recursive_declaration fixnames fixrs fixtypes fixdefs in + let fix_kind = Decls.IsDefinition fix_kind in let _ : GlobRef.t list = - List.map4 (fun name body types imps -> - let ce = Declare.definition_entry ~opaque:false ~types ~univs:ctx body in - DeclareDef.declare_definition ~name ~scope ~kind:fix_kind udecl ce imps) - fixnames fixdecls fixtypes fiximps + DeclareDef.declare_mutually_recursive ~scope ~opaque:false ~kind:fix_kind ~poly ~uctx + ~possible_indexes:indexes ~restrict_ucontext:true ~udecl ~ntns ~rec_declaration + fixitems in - recursive_message (not cofix) gidx fixnames; - List.iter (Metasyntax.add_notation_interpretation (Global.env())) ntns; () -let extract_decreasing_argument ~structonly = function { CAst.v = v } -> match v with +let extract_decreasing_argument ~structonly { CAst.v = v; _ } = + let open Constrexpr in + match v with | CStructRec na -> na | (CWfRec (na,_) | CMeasureRec (Some na,_,_)) when not structonly -> na | CMeasureRec (None,_,_) when not structonly -> - user_err Pp.(str "Decreasing argument must be specified in measure clause.") - | _ -> user_err Pp.(str - "Well-founded induction requires Program Fixpoint or Function.") + CErrors.user_err Pp.(str "Decreasing argument must be specified in measure clause.") + | _ -> + CErrors.user_err Pp.(str "Well-founded induction requires Program Fixpoint or Function.") (* This is a special case: if there's only one binder, we pick it as the recursive argument if none is provided. *) let adjust_rec_order ~structonly binders rec_order = - let rec_order = Option.map (fun rec_order -> match binders, rec_order with + let rec_order = Option.map (fun rec_order -> + let open Constrexpr in + match binders, rec_order with | [CLocalAssum([{ CAst.v = Name x }],_,_)], { CAst.v = CMeasureRec(None, mes, rel); CAst.loc } -> CAst.make ?loc @@ CMeasureRec(Some (CAst.make x), mes, rel) | [CLocalDef({ CAst.v = Name x },_,_)], { CAst.v = CMeasureRec(None, mes, rel); CAst.loc } -> diff --git a/vernac/comFixpoint.mli b/vernac/comFixpoint.mli index 2ad6c03bae..a19b96f0f3 100644 --- a/vernac/comFixpoint.mli +++ b/vernac/comFixpoint.mli @@ -9,7 +9,6 @@ (************************************************************************) open Names -open Constr open Vernacexpr (** {6 Fixpoints and cofixpoints} *) @@ -40,6 +39,9 @@ val adjust_rec_order -> Constrexpr.recursion_order_expr option -> lident option +(** names / relevance / defs / types *) +type ('constr, 'types) recursive_preentry = Id.t list * Sorts.relevance list * 'constr option list * 'types list + (** Exported for Program *) val interp_recursive : (* Misc arguments *) @@ -49,18 +51,17 @@ val interp_recursive : (* env / signature / univs / evar_map *) (Environ.env * EConstr.named_context * UState.universe_decl * Evd.evar_map) * (* names / defs / types *) - (Id.t list * Sorts.relevance list * EConstr.constr option list * EConstr.types list) * + (EConstr.t, EConstr.types) recursive_preentry * (* ctx per mutual def / implicits / struct annotations *) (EConstr.rel_context * Impargs.manual_implicits * int option) list (** Exported for Funind *) -type recursive_preentry = Id.t list * Sorts.relevance list * constr option list * types list - val interp_fixpoint : cofix:bool -> lident option fix_expr_gen list - -> recursive_preentry * UState.universe_decl * UState.t * + -> (Constr.t, Constr.types) recursive_preentry * + UState.universe_decl * UState.t * (EConstr.rel_context * Impargs.manual_implicits * int option) list (** Very private function, do not use *) diff --git a/vernac/comProgramFixpoint.ml b/vernac/comProgramFixpoint.ml index 4f9c247b71..56780d00a6 100644 --- a/vernac/comProgramFixpoint.ml +++ b/vernac/comProgramFixpoint.ml @@ -115,7 +115,7 @@ let build_wellfounded (recname,pl,bl,arityc,body) poly r measure notation = let lift_rel_context n l = Termops.map_rel_context_with_binders (liftn n) l in Coqlib.check_required_library ["Coq";"Program";"Wf"]; let env = Global.env() in - let sigma, decl = Constrexpr_ops.interp_univ_decl_opt env pl in + let sigma, udecl = Constrexpr_ops.interp_univ_decl_opt env pl in let sigma, (_, ((env', binders_rel), impls)) = interp_context_evars ~program_mode:true env sigma bl in let len = List.length binders_rel in let top_env = push_rel_context binders_rel env in @@ -234,7 +234,7 @@ let build_wellfounded (recname,pl,bl,arityc,body) poly r measure notation = let body = it_mkLambda_or_LetIn (mkApp (h_body, [|make|])) binders_rel in let ty = it_mkProd_or_LetIn top_arity binders_rel in let ty = EConstr.Unsafe.to_constr ty in - let univs = Evd.check_univ_decl ~poly sigma decl in + let univs = Evd.check_univ_decl ~poly sigma udecl in (*FIXME poly? *) let ce = definition_entry ~types:ty ~univs (EConstr.to_constr sigma body) in (* FIXME: include locality *) @@ -254,13 +254,13 @@ let build_wellfounded (recname,pl,bl,arityc,body) poly r measure notation = in (* XXX: Capturing sigma here... bad bad *) let hook = DeclareDef.Hook.make (hook sigma) in - Obligations.check_evars env sigma; + RetrieveObl.check_evars env sigma; let evars, _, evars_def, evars_typ = - Obligations.eterm_obligations env recname sigma 0 def typ + RetrieveObl.retrieve_obligations env recname sigma 0 def typ in - let ctx = Evd.evar_universe_context sigma in - ignore(Obligations.add_definition ~name:recname ~term:evars_def ~univdecl:decl - ~poly evars_typ ctx evars ~hook) + let uctx = Evd.evar_universe_context sigma in + ignore(Obligations.add_definition ~name:recname ~term:evars_def ~udecl + ~poly evars_typ ~uctx evars ~hook) let out_def = function | Some def -> def @@ -273,7 +273,7 @@ let collect_evars_of_term evd c ty = let do_program_recursive ~scope ~poly fixkind fixl = let cofix = fixkind = DeclareObl.IsCoFixpoint in - let (env, rec_sign, pl, evd), fix, info = + let (env, rec_sign, udecl, evd), fix, info = interp_recursive ~cofix ~program_mode:true fixl in (* Program-specific code *) @@ -281,15 +281,15 @@ let do_program_recursive ~scope ~poly fixkind fixl = let evd = Typeclasses.resolve_typeclasses ~filter:Typeclasses.no_goals ~fail:true env evd in (* Solve remaining evars *) let evd = nf_evar_map_undefined evd in - let collect_evars id def typ imps = + let collect_evars name def typ impargs = (* Generalize by the recursive prototypes *) let def = nf_evar evd (Termops.it_mkNamedLambda_or_LetIn def rec_sign) in let typ = nf_evar evd (Termops.it_mkNamedProd_or_LetIn typ rec_sign) in let evm = collect_evars_of_term evd def typ in let evars, _, def, typ = - Obligations.eterm_obligations env id evm + RetrieveObl.retrieve_obligations env name evm (List.length rec_sign) def typ in - (id, def, typ, imps, evars) + ({ DeclareDef.Recthm.name; typ; impargs; args = [] }, def, evars) in let (fixnames,fixrs,fixdefs,fixtypes) = fix in let fiximps = List.map pi2 info in @@ -311,13 +311,13 @@ let do_program_recursive ~scope ~poly fixkind fixl = ((indexes,i),fixdecls)) fixl end in - let ctx = Evd.evar_universe_context evd in + let uctx = Evd.evar_universe_context evd in let kind = match fixkind with | DeclareObl.IsFixpoint _ -> Decls.Fixpoint | DeclareObl.IsCoFixpoint -> Decls.CoFixpoint in let ntns = List.map_append (fun { Vernacexpr.notations } -> notations ) fixl in - Obligations.add_mutual_definitions defs ~poly ~scope ~kind ~univdecl:pl ctx ntns fixkind + Obligations.add_mutual_definitions defs ~poly ~scope ~kind ~udecl ~uctx ntns fixkind let do_fixpoint ~scope ~poly l = let g = List.map (fun { Vernacexpr.rec_order } -> rec_order) l in diff --git a/vernac/declareDef.ml b/vernac/declareDef.ml index a032ebf3f9..1607771598 100644 --- a/vernac/declareDef.ml +++ b/vernac/declareDef.ml @@ -9,7 +9,6 @@ (************************************************************************) open Declare -open Impargs type locality = Discharge | Global of Declare.import_status @@ -34,47 +33,97 @@ module Hook = struct let make hook = CEphemeron.create hook - let call ?hook ?fix_exn x = - try Option.iter (fun hook -> CEphemeron.get hook x) hook - with e when CErrors.noncritical e -> - let e = Exninfo.capture e in - let e = Option.cata (fun fix -> fix e) e fix_exn in - Exninfo.iraise e + let call ?hook x = Option.iter (fun hook -> CEphemeron.get hook x) hook + end (* Locality stuff *) -let declare_definition ~name ~scope ~kind ?hook_data udecl ce imps = - let fix_exn = Declare.Internal.get_fix_exn ce in - let should_suggest = ce.Declare.proof_entry_opaque && - Option.is_empty ce.Declare.proof_entry_secctx in +let declare_entry ~name ~scope ~kind ?hook ?(obls=[]) ~impargs ~uctx entry = + let should_suggest = entry.Declare.proof_entry_opaque && + Option.is_empty entry.Declare.proof_entry_secctx in + let ubind = UState.universe_binders uctx in let dref = match scope with | Discharge -> - let () = declare_variable ~name ~kind (SectionLocalDef ce) in + let () = declare_variable ~name ~kind (SectionLocalDef entry) in if should_suggest then Proof_using.suggest_variable (Global.env ()) name; Names.GlobRef.VarRef name | Global local -> - let kn = declare_constant ~name ~local ~kind (DefinitionEntry ce) in + let kn = declare_constant ~name ~local ~kind (DefinitionEntry entry) in let gr = Names.GlobRef.ConstRef kn in if should_suggest then Proof_using.suggest_constant (Global.env ()) kn; - let () = DeclareUniv.declare_univ_binders gr udecl in + let () = DeclareUniv.declare_univ_binders gr ubind in gr in - let () = maybe_declare_manual_implicits false dref imps in + let () = Impargs.maybe_declare_manual_implicits false dref impargs in let () = definition_message name in - begin - match hook_data with - | None -> () - | Some (hook, uctx, obls) -> - Hook.call ~fix_exn ~hook { Hook.S.uctx; obls; scope; dref } - end; + Option.iter (fun hook -> Hook.call ~hook { Hook.S.uctx; obls; scope; dref }) hook; dref +let declare_entry ~name ~scope ~kind ?hook ?obls ~impargs ~uctx entry = + try declare_entry ~name ~scope ~kind ?hook ?obls ~impargs ~uctx entry + with exn -> + let exn = Exninfo.capture exn in + let fix_exn = Declare.Internal.get_fix_exn entry in + Exninfo.iraise (fix_exn exn) + +let mutual_make_bodies ~fixitems ~rec_declaration ~possible_indexes = + match possible_indexes with + | Some possible_indexes -> + let env = Global.env() in + let indexes = Pretyping.search_guard env possible_indexes rec_declaration in + let vars = Vars.universes_of_constr (Constr.mkFix ((indexes,0),rec_declaration)) in + let fixdecls = CList.map_i (fun i _ -> Constr.mkFix ((indexes,i),rec_declaration)) 0 fixitems in + vars, fixdecls, Some indexes + | None -> + let fixdecls = CList.map_i (fun i _ -> Constr.mkCoFix (i,rec_declaration)) 0 fixitems in + let vars = Vars.universes_of_constr (List.hd fixdecls) in + vars, fixdecls, None + +module Recthm = struct + type t = + { name : Names.Id.t + (** Name of theorem *) + ; typ : Constr.t + (** Type of theorem *) + ; args : Names.Name.t list + (** Names to pre-introduce *) + ; impargs : Impargs.manual_implicits + (** Explicitily declared implicit arguments *) + } +end + +let declare_mutually_recursive ~opaque ~scope ~kind ~poly ~uctx ~udecl ~ntns ~rec_declaration ~possible_indexes ?(restrict_ucontext=true) fixitems = + let vars, fixdecls, indexes = + mutual_make_bodies ~fixitems ~rec_declaration ~possible_indexes in + let uctx, univs = + (* XXX: Obligations don't do this, this seems like a bug? *) + if restrict_ucontext + then + let uctx = UState.restrict uctx vars in + let univs = UState.check_univ_decl ~poly uctx udecl in + uctx, univs + else + let univs = UState.univ_entry ~poly uctx in + uctx, univs + in + let csts = CList.map2 + (fun Recthm.{ name; typ; impargs } body -> + let entry = Declare.definition_entry ~opaque ~types:typ ~univs body in + declare_entry ~name ~scope ~kind ~impargs ~uctx entry) + fixitems fixdecls + in + let isfix = Option.is_empty possible_indexes in + let fixnames = List.map (fun { Recthm.name } -> name) fixitems in + Declare.recursive_message isfix indexes fixnames; + List.iter (Metasyntax.add_notation_interpretation (Global.env())) ntns; + csts + let warn_let_as_axiom = CWarnings.create ~name:"let-as-axiom" ~category:"vernacular" Pp.(fun id -> strbrk "Let definition" ++ spc () ++ Names.Id.print id ++ spc () ++ strbrk "declared as an axiom.") -let declare_assumption ?fix_exn ~name ~scope ~hook ~impargs ~uctx pe = +let declare_assumption ~name ~scope ~hook ~impargs ~uctx pe = let local = match scope with | Discharge -> warn_let_as_axiom name; Declare.ImportNeedQualified | Global local -> local @@ -86,27 +135,59 @@ let declare_assumption ?fix_exn ~name ~scope ~hook ~impargs ~uctx pe = let () = Impargs.maybe_declare_manual_implicits false dref impargs in let () = Declare.assumption_message name in let () = DeclareUniv.declare_univ_binders dref (UState.universe_binders uctx) in - let () = Hook.(call ?fix_exn ?hook { S.uctx; obls = []; scope; dref}) in + let () = Hook.(call ?hook { S.uctx; obls = []; scope; dref}) in dref +let declare_assumption ?fix_exn ~name ~scope ~hook ~impargs ~uctx pe = + try declare_assumption ~name ~scope ~hook ~impargs ~uctx pe + with exn -> + let exn = Exninfo.capture exn in + let exn = Option.cata (fun fix -> fix exn) exn fix_exn in + Exninfo.iraise exn + (* Preparing proof entries *) -let check_definition_evars ~allow_evars sigma = +let prepare_definition ?opaque ?inline ?fix_exn ~poly ~udecl ~types ~body sigma = let env = Global.env () in - if not allow_evars then Pretyping.check_evars_are_solved ~program_mode:false env sigma + Pretyping.check_evars_are_solved ~program_mode:false env sigma; + let sigma, (body, types) = Evarutil.finalize ~abort_on_undefined_evars:true + sigma (fun nf -> nf body, Option.map nf types) + in + let univs = Evd.check_univ_decl ~poly sigma udecl in + let entry = definition_entry ?fix_exn ?opaque ?inline ?types ~univs body in + let uctx = Evd.evar_universe_context sigma in + entry, uctx -let prepare_definition ~allow_evars ?opaque ?inline ~poly sigma udecl ~types ~body = - check_definition_evars ~allow_evars sigma; - let sigma, (body, types) = Evarutil.finalize ~abort_on_undefined_evars:(not allow_evars) +let declare_definition ~name ~scope ~kind ~opaque ~impargs ~udecl ?hook + ?obls ~poly ?inline ~types ~body ?fix_exn sigma = + let entry, uctx = prepare_definition ?fix_exn ~opaque ~poly ~udecl ~types ~body ?inline sigma in + declare_entry ~name ~scope ~kind ~impargs ?obls ?hook ~uctx entry + +let prepare_obligation ?opaque ?inline ~name ~poly ~udecl ~types ~body sigma = + let sigma, (body, types) = Evarutil.finalize ~abort_on_undefined_evars:false sigma (fun nf -> nf body, Option.map nf types) in let univs = Evd.check_univ_decl ~poly sigma udecl in - sigma, definition_entry ?opaque ?inline ?types ~univs body + let ce = definition_entry ?opaque ?inline ?types ~univs body in + let env = Global.env () in + let (c,ctx), sideff = Future.force ce.Declare.proof_entry_body in + assert(Safe_typing.empty_private_constants = sideff.Evd.seff_private); + assert(Univ.ContextSet.is_empty ctx); + RetrieveObl.check_evars env sigma; + let c = EConstr.of_constr c in + let typ = match ce.Declare.proof_entry_type with + | Some t -> EConstr.of_constr t + | None -> Retyping.get_type_of env sigma c + in + let obls, _, c, cty = RetrieveObl.retrieve_obligations env name sigma 0 c typ in + let uctx = Evd.evar_universe_context sigma in + c, cty, uctx, obls -let prepare_parameter ~allow_evars ~poly sigma udecl typ = - check_definition_evars ~allow_evars sigma; - let sigma, typ = Evarutil.finalize ~abort_on_undefined_evars:(not allow_evars) - sigma (fun nf -> nf typ) +let prepare_parameter ~poly ~udecl ~types sigma = + let env = Global.env () in + Pretyping.check_evars_are_solved ~program_mode:false env sigma; + let sigma, typ = Evarutil.finalize ~abort_on_undefined_evars:true + sigma (fun nf -> nf types) in let univs = Evd.check_univ_decl ~poly sigma udecl in sigma, (None(*proof using*), (typ, univs), None(*inline*)) diff --git a/vernac/declareDef.mli b/vernac/declareDef.mli index 1ff2145c0d..3bc1e25f19 100644 --- a/vernac/declareDef.mli +++ b/vernac/declareDef.mli @@ -36,17 +36,42 @@ module Hook : sig end val make : (S.t -> unit) -> t - val call : ?hook:t -> ?fix_exn:Future.fix_exn -> S.t -> unit + val call : ?hook:t -> S.t -> unit end -val declare_definition +(** Declare an interactively-defined constant *) +val declare_entry : name:Id.t -> scope:locality -> kind:Decls.logical_kind - -> ?hook_data:(Hook.t * UState.t * (Id.t * Constr.t) list) - -> UnivNames.universe_binders + -> ?hook:Hook.t + -> ?obls:(Id.t * Constr.t) list + -> impargs:Impargs.manual_implicits + -> uctx:UState.t -> Evd.side_effects Declare.proof_entry - -> Impargs.manual_implicits + -> GlobRef.t + +(** Declares a non-interactive constant; [body] and [types] will be + normalized w.r.t. the passed [evar_map] [sigma]. Universes should + be handled properly, including minimization and restriction. Note + that [sigma] is checked for unresolved evars, thus you should be + careful not to submit open terms or evar maps with stale, + unresolved existentials *) +val declare_definition + : name:Id.t + -> scope:locality + -> kind:Decls.logical_kind + -> opaque:bool + -> impargs:Impargs.manual_implicits + -> udecl:UState.universe_decl + -> ?hook:Hook.t + -> ?obls:(Id.t * Constr.t) list + -> poly:bool + -> ?inline:bool + -> types:EConstr.t option + -> body:EConstr.t + -> ?fix_exn:(Exninfo.iexn -> Exninfo.iexn) + -> Evd.evar_map -> GlobRef.t val declare_assumption @@ -59,17 +84,49 @@ val declare_assumption -> Entries.parameter_entry -> GlobRef.t -val prepare_definition - : allow_evars:bool - -> ?opaque:bool +module Recthm : sig + type t = + { name : Id.t + (** Name of theorem *) + ; typ : Constr.t + (** Type of theorem *) + ; args : Name.t list + (** Names to pre-introduce *) + ; impargs : Impargs.manual_implicits + (** Explicitily declared implicit arguments *) + } +end + +val declare_mutually_recursive + : opaque:bool + -> scope:locality + -> kind:Decls.logical_kind + -> poly:bool + -> uctx:UState.t + -> udecl:UState.universe_decl + -> ntns:Vernacexpr.decl_notation list + -> rec_declaration:Constr.rec_declaration + -> possible_indexes:int list list option + -> ?restrict_ucontext:bool + (** XXX: restrict_ucontext should be always true, this seems like a + bug in obligations, so this parameter should go away *) + -> Recthm.t list + -> Names.GlobRef.t list + +val prepare_obligation + : ?opaque:bool -> ?inline:bool + -> name:Id.t -> poly:bool - -> Evd.evar_map - -> UState.universe_decl + -> udecl:UState.universe_decl -> types:EConstr.t option -> body:EConstr.t - -> Evd.evar_map * Evd.side_effects Declare.proof_entry + -> Evd.evar_map + -> Constr.constr * Constr.types * UState.t * RetrieveObl.obligation_info -val prepare_parameter : allow_evars:bool -> - poly:bool -> Evd.evar_map -> UState.universe_decl -> EConstr.types -> - Evd.evar_map * Entries.parameter_entry +val prepare_parameter + : poly:bool + -> udecl:UState.universe_decl + -> types:EConstr.types + -> Evd.evar_map + -> Evd.evar_map * Entries.parameter_entry diff --git a/vernac/declareObl.ml b/vernac/declareObl.ml index a081aa3dae..bba3687256 100644 --- a/vernac/declareObl.ml +++ b/vernac/declareObl.ml @@ -18,39 +18,96 @@ open Entries type 'a obligation_body = DefinedObl of 'a | TermObl of constr -type obligation = - { obl_name : Id.t - ; obl_type : types - ; obl_location : Evar_kinds.t Loc.located - ; obl_body : pconstant obligation_body option - ; obl_status : bool * Evar_kinds.obligation_definition_status - ; obl_deps : Int.Set.t - ; obl_tac : unit Proofview.tactic option } +module Obligation = struct + type t = + { obl_name : Id.t + ; obl_type : types + ; obl_location : Evar_kinds.t Loc.located + ; obl_body : pconstant obligation_body option + ; obl_status : bool * Evar_kinds.obligation_definition_status + ; obl_deps : Int.Set.t + ; obl_tac : unit Proofview.tactic option } -type obligations = obligation array * int + let set_type ~typ obl = { obl with obl_type = typ } + let set_body ~body obl = { obl with obl_body = Some body } + +end + +type obligations = + { obls : Obligation.t array + ; remaining : int } type fixpoint_kind = | IsFixpoint of lident option list | IsCoFixpoint -type program_info = - { prg_name : Id.t - ; prg_body : constr - ; prg_type : constr - ; prg_ctx : UState.t - ; prg_univdecl : UState.universe_decl - ; prg_obligations : obligations - ; prg_deps : Id.t list - ; prg_fixkind : fixpoint_kind option - ; prg_implicits : Impargs.manual_implicits - ; prg_notations : Vernacexpr.decl_notation list - ; prg_poly : bool - ; prg_scope : DeclareDef.locality - ; prg_kind : Decls.definition_object_kind - ; prg_reduce : constr -> constr - ; prg_hook : DeclareDef.Hook.t option - ; prg_opaque : bool - } +module ProgramDecl = struct + + type t = + { prg_name : Id.t + ; prg_body : constr + ; prg_type : constr + ; prg_ctx : UState.t + ; prg_univdecl : UState.universe_decl + ; prg_obligations : obligations + ; prg_deps : Id.t list + ; prg_fixkind : fixpoint_kind option + ; prg_implicits : Impargs.manual_implicits + ; prg_notations : Vernacexpr.decl_notation list + ; prg_poly : bool + ; prg_scope : DeclareDef.locality + ; prg_kind : Decls.definition_object_kind + ; prg_reduce : constr -> constr + ; prg_hook : DeclareDef.Hook.t option + ; prg_opaque : bool + } + + open Obligation + + let make ?(opaque = false) ?hook n ~udecl ~uctx ~impargs + ~poly ~scope ~kind b t deps fixkind notations obls reduce = + let obls', b = + match b with + | None -> + assert(Int.equal (Array.length obls) 0); + let n = Nameops.add_suffix n "_obligation" in + [| { obl_name = n; obl_body = None; + obl_location = Loc.tag Evar_kinds.InternalHole; obl_type = t; + obl_status = false, Evar_kinds.Expand; obl_deps = Int.Set.empty; + obl_tac = None } |], + mkVar n + | Some b -> + Array.mapi + (fun i (n, t, l, o, d, tac) -> + { obl_name = n ; obl_body = None; + obl_location = l; obl_type = t; obl_status = o; + obl_deps = d; obl_tac = tac }) + obls, b + in + let ctx = UState.make_flexible_nonalgebraic uctx in + { prg_name = n + ; prg_body = b + ; prg_type = reduce t + ; prg_ctx = ctx + ; prg_univdecl = udecl + ; prg_obligations = { obls = obls' ; remaining = Array.length obls' } + ; prg_deps = deps + ; prg_fixkind = fixkind + ; prg_notations = notations + ; prg_implicits = impargs + ; prg_poly = poly + ; prg_scope = scope + ; prg_kind = kind + ; prg_reduce = reduce + ; prg_hook = hook + ; prg_opaque = opaque + } + + let set_uctx ~uctx prg = {prg with prg_ctx = uctx} +end + +open Obligation +open ProgramDecl (* Saving an obligation *) @@ -120,16 +177,16 @@ let shrink_body c ty = in (ctx, b', ty', Array.of_list args) +(***********************************************************************) +(* Saving an obligation *) +(***********************************************************************) + let unfold_entry cst = Hints.HintsUnfoldEntry [EvalConstRef cst] let add_hint local prg cst = let locality = if local then Goptions.OptLocal else Goptions.OptExport in Hints.add_hints ~locality [Id.to_string prg.prg_name] (unfold_entry cst) -(***********************************************************************) -(* Saving an obligation *) -(***********************************************************************) - (* true = hide obligations *) let get_hide_obligations = Goptions.declare_bool_option_and_ref @@ -194,45 +251,24 @@ let get_prg_info_map () = !from_prg let map_keys m = ProgMap.fold (fun k _ l -> k :: l) m [] -let close sec = +let check_can_close sec = if not (ProgMap.is_empty !from_prg) then let keys = map_keys !from_prg in CErrors.user_err ~hdr:"Program" Pp.( str "Unsolved obligations when closing " - ++ str sec ++ str ":" ++ spc () + ++ Id.print sec ++ str ":" ++ spc () ++ prlist_with_sep spc (fun x -> Id.print x) keys ++ ( str (if Int.equal (List.length keys) 1 then " has " else " have ") ++ str "unsolved obligations" )) -let input : program_info CEphemeron.key ProgMap.t -> Libobject.obj = - let open Libobject in - declare_object - { (default_object "Program state") with - cache_function = (fun (na, pi) -> from_prg := pi) - ; load_function = (fun _ (_, pi) -> from_prg := pi) - ; discharge_function = - (fun _ -> - close "section"; - None ) - ; classify_function = - (fun _ -> - close "module"; - Dispose ) } - -let map_replace k v m = - ProgMap.add k (CEphemeron.create v) (ProgMap.remove k m) - -let progmap_remove prg = - Lib.add_anonymous_leaf (input (ProgMap.remove prg.prg_name !from_prg)) - -let progmap_add n prg = - Lib.add_anonymous_leaf (input (ProgMap.add n prg !from_prg)) +let map_replace k v m = ProgMap.add k (CEphemeron.create v) (ProgMap.remove k m) +let prgmap_op f = from_prg := f !from_prg +let progmap_remove prg = prgmap_op (ProgMap.remove prg.prg_name) +let progmap_add n prg = prgmap_op (ProgMap.add n prg) +let progmap_replace prg = prgmap_op (map_replace prg.prg_name prg) -let progmap_replace prg' = - Lib.add_anonymous_leaf (input (map_replace prg'.prg_name prg' !from_prg)) - -let obligations_solved prg = Int.equal (snd prg.prg_obligations) 0 +let obligations_solved prg = Int.equal prg.prg_obligations.remaining 0 let obligations_message rem = if rem > 0 then @@ -272,7 +308,7 @@ let rec intset_to = function | n -> Int.Set.add n (intset_to (pred n)) let obligation_substitution expand prg = - let obls, _ = prg.prg_obligations in + let obls = prg.prg_obligations.obls in let ints = intset_to (pred (Array.length obls)) in obl_substitution expand obls ints @@ -326,34 +362,21 @@ let get_fix_exn, stm_get_fix_exn = Hook.make () let declare_definition prg = let varsubst = obligation_substitution true prg in - let body, typ = subst_prog varsubst prg in - let nf = - UnivSubst.nf_evars_and_universes_opt_subst - (fun x -> None) - (UState.subst prg.prg_ctx) - in - let opaque = prg.prg_opaque in + let sigma = Evd.from_ctx prg.prg_ctx in + let body, types = subst_prog varsubst prg in + let body, types = EConstr.(of_constr body, Some (of_constr types)) in + (* All these should be grouped into a struct a some point *) + let opaque, poly, udecl, hook = prg.prg_opaque, prg.prg_poly, prg.prg_univdecl, prg.prg_hook in + let name, scope, kind, impargs = prg.prg_name, prg.prg_scope, Decls.(IsDefinition prg.prg_kind), prg.prg_implicits in let fix_exn = Hook.get get_fix_exn () in - let typ = nf typ in - let body = nf body in - let obls = List.map (fun (id, (_, c)) -> (id, nf c)) varsubst in - let uvars = - Univ.LSet.union - (Vars.universes_of_constr typ) - (Vars.universes_of_constr body) - in - let uctx = UState.restrict prg.prg_ctx uvars in - let univs = - UState.check_univ_decl ~poly:prg.prg_poly uctx prg.prg_univdecl - in - let ce = Declare.definition_entry ~fix_exn ~opaque ~types:typ ~univs body in + let obls = List.map (fun (id, (_, c)) -> (id, c)) varsubst in + (* XXX: This is doing normalization twice *) let () = progmap_remove prg in - let ubinders = UState.universe_binders uctx in - let hook_data = Option.map (fun hook -> hook, uctx, obls) prg.prg_hook in - DeclareDef.declare_definition - ~name:prg.prg_name ~scope:prg.prg_scope ubinders - ~kind:Decls.(IsDefinition prg.prg_kind) ce - prg.prg_implicits ?hook_data + let kn = + DeclareDef.declare_definition ~name ~scope ~kind ~impargs ?hook ~obls + ~fix_exn ~opaque ~poly ~udecl ~types ~body sigma + in + kn let rec lam_index n t acc = match Constr.kind t with @@ -400,55 +423,42 @@ let declare_mutual_definition l = (xdef :: defs, xobls @ obls)) l ([], []) in (* let fixdefs = List.map reduce_fix fixdefs in *) - let fixdefs, fixrs,fixtypes, fiximps = List.split4 defs in + let fixdefs, fixrs, fixtypes, fixitems = + List.fold_right2 (fun (d,r,typ,impargs) name (a1,a2,a3,a4) -> + d :: a1, r :: a2, typ :: a3, + DeclareDef.Recthm.{ name; typ; impargs; args = [] } :: a4 + ) defs first.prg_deps ([],[],[],[]) + in let fixkind = Option.get first.prg_fixkind in let arrrec, recvec = (Array.of_list fixtypes, Array.of_list fixdefs) in let rvec = Array.of_list fixrs in let namevec = Array.of_list (List.map (fun x -> Name x.prg_name) l) in - let fixdecls = (Array.map2 make_annot namevec rvec, arrrec, recvec) in - let fixnames = first.prg_deps in - let opaque = first.prg_opaque in - let indexes, fixdecls = + let rec_declaration = (Array.map2 make_annot namevec rvec, arrrec, recvec) in + let possible_indexes = match fixkind with | IsFixpoint wfl -> - let possible_indexes = - List.map3 compute_possible_guardness_evidences wfl fixdefs fixtypes - in - let indexes = - Pretyping.search_guard (Global.env ()) possible_indexes fixdecls - in - ( Some indexes - , List.map_i (fun i _ -> mkFix ((indexes, i), fixdecls)) 0 l - ) - | IsCoFixpoint -> - (None, List.map_i (fun i _ -> mkCoFix (i, fixdecls)) 0 l) + Some (List.map3 compute_possible_guardness_evidences wfl fixdefs fixtypes) + | IsCoFixpoint -> None in + (* In the future we will pack all this in a proper record *) + let poly, scope, ntns, opaque = first.prg_poly, first.prg_scope, first.prg_notations, first.prg_opaque in + let kind = if fixkind != IsCoFixpoint then Decls.(IsDefinition Fixpoint) else Decls.(IsDefinition CoFixpoint) in (* Declare the recursive definitions *) - let poly = first.prg_poly in - let scope = first.prg_scope in - let univs = UState.univ_entry ~poly first.prg_ctx in - let fix_exn = Hook.get get_fix_exn () in - let kind = Decls.IsDefinition (if fixkind != IsCoFixpoint then Decls.Fixpoint else Decls.CoFixpoint) in - let udecl = UnivNames.empty_binders in + let udecl = UState.default_univ_decl in let kns = - List.map4 - (fun name body types imps -> - let ce = Declare.definition_entry ~opaque ~types ~univs body in - DeclareDef.declare_definition ~name ~scope ~kind udecl ce imps) - fixnames fixdecls fixtypes fiximps + DeclareDef.declare_mutually_recursive ~scope ~opaque ~kind + ~udecl ~ntns ~uctx:first.prg_ctx ~rec_declaration ~possible_indexes ~poly + ~restrict_ucontext:false fixitems in - (* Declare notations *) - List.iter - (Metasyntax.add_notation_interpretation (Global.env ())) - first.prg_notations; - Declare.recursive_message (fixkind != IsCoFixpoint) indexes fixnames; + (* Only for the first constant *) let dref = List.hd kns in - DeclareDef.Hook.(call ?hook:first.prg_hook ~fix_exn { S.uctx = first.prg_ctx; obls; scope; dref }); + DeclareDef.Hook.(call ?hook:first.prg_hook { S.uctx = first.prg_ctx; obls; scope; dref }); List.iter progmap_remove l; dref let update_obls prg obls rem = - let prg' = {prg with prg_obligations = (obls, rem)} in + let prg_obligations = { obls; remaining = rem } in + let prg' = {prg with prg_obligations} in progmap_replace prg'; obligations_message rem; if rem > 0 then Remain rem @@ -478,6 +488,17 @@ let dependencies obls n = obls; !res +let update_program_decl_on_defined prg obls num obl ~uctx rem ~auto = + let obls = Array.copy obls in + let () = obls.(num) <- obl in + let prg = { prg with prg_ctx = uctx } in + let () = ignore (update_obls prg obls (pred rem)) in + if pred rem > 0 then begin + let deps = dependencies obls num in + if not (Int.Set.is_empty deps) then + ignore (auto (Some prg.prg_name) deps None) + end + type obligation_qed_info = { name : Id.t ; num : int @@ -489,16 +510,12 @@ let obligation_terminator entries uctx { name; num; auto } = | [entry] -> let env = Global.env () in let ty = entry.Declare.proof_entry_type in - let body, uctx = Declare.inline_private_constants ~univs:uctx env entry in + let body, uctx = Declare.inline_private_constants ~uctx env entry in let sigma = Evd.from_ctx uctx in Inductiveops.control_only_guard (Global.env ()) sigma (EConstr.of_constr body); (* Declare the obligation ourselves and drop the hook *) let prg = CEphemeron.get (ProgMap.find name !from_prg) in - (* Ensure universes are substituted properly in body and type *) - let body = EConstr.to_constr sigma (EConstr.of_constr body) in - let ty = Option.map (fun x -> EConstr.to_constr sigma (EConstr.of_constr x)) ty in - let ctx = Evd.evar_universe_context sigma in - let obls, rem = prg.prg_obligations in + let { obls; remaining=rem } = prg.prg_obligations in let obl = obls.(num) in let status = match obl.obl_status, entry.Declare.proof_entry_opaque with @@ -510,36 +527,57 @@ let obligation_terminator entries uctx { name; num; auto } = | (_, status), false -> status in let obl = { obl with obl_status = false, status } in - let ctx = - if prg.prg_poly then ctx - else UState.union prg.prg_ctx ctx + let uctx = + if prg.prg_poly then uctx + else UState.union prg.prg_ctx uctx in - let uctx = UState.univ_entry ~poly:prg.prg_poly ctx in - let (defined, obl) = declare_obligation prg obl body ty uctx in - let obls = Array.copy obls in - let () = obls.(num) <- obl in + let univs = UState.univ_entry ~poly:prg.prg_poly uctx in + let (defined, obl) = declare_obligation prg obl body ty univs in let prg_ctx = if prg.prg_poly then (* Polymorphic *) (* We merge the new universes and constraints of the polymorphic obligation with the existing ones *) - UState.union prg.prg_ctx ctx + UState.union prg.prg_ctx uctx else (* The first obligation, if defined, declares the univs of the constant, each subsequent obligation declares its own additional universes and constraints if any *) if defined then UState.make ~lbound:(Global.universes_lbound ()) (Global.universes ()) - else ctx + else uctx in - let prg = {prg with prg_ctx} in - ignore (update_obls prg obls (pred rem)); - if pred rem > 0 then - let deps = dependencies obls num in - if not (Int.Set.is_empty deps) then - ignore (auto (Some name) deps None) + update_program_decl_on_defined prg obls num obl ~uctx:prg_ctx rem ~auto | _ -> CErrors.anomaly Pp.( str "[obligation_terminator] close_proof returned more than one proof \ term") + +(* Similar to the terminator but for interactive paths, as the + terminator is only called in interactive proof mode *) +let obligation_hook prg obl num auto { DeclareDef.Hook.S.uctx = ctx'; dref; _ } = + let { obls; remaining=rem } = prg.prg_obligations in + let cst = match dref with GlobRef.ConstRef cst -> cst | _ -> assert false in + let transparent = evaluable_constant cst (Global.env ()) in + let () = match obl.obl_status with + (true, Evar_kinds.Expand) + | (true, Evar_kinds.Define true) -> + if not transparent then err_not_transp () + | _ -> () + in + let inst, ctx' = + if not prg.prg_poly (* Not polymorphic *) then + (* The universe context was declared globally, we continue + from the new global environment. *) + let ctx = UState.make ~lbound:(Global.universes_lbound ()) (Global.universes ()) in + let ctx' = UState.merge_subst ctx (UState.subst ctx') in + Univ.Instance.empty, ctx' + else + (* We get the right order somehow, but surely it could be enforced in a clearer way. *) + let uctx = UState.context ctx' in + Univ.UContext.instance uctx, ctx' + in + let obl = { obl with obl_body = Some (DefinedObl (cst, inst)) } in + let () = if transparent then add_hint true prg cst in + update_program_decl_on_defined prg obls num obl ~uctx:ctx' rem ~auto diff --git a/vernac/declareObl.mli b/vernac/declareObl.mli index 6e7700a28a..16c0413caf 100644 --- a/vernac/declareObl.mli +++ b/vernac/declareObl.mli @@ -13,61 +13,101 @@ open Constr type 'a obligation_body = DefinedObl of 'a | TermObl of constr -type obligation = - { obl_name : Id.t - ; obl_type : types - ; obl_location : Evar_kinds.t Loc.located - ; obl_body : pconstant obligation_body option - ; obl_status : bool * Evar_kinds.obligation_definition_status - ; obl_deps : Int.Set.t - ; obl_tac : unit Proofview.tactic option } +module Obligation : sig -type obligations = obligation array * int + type t = private + { obl_name : Id.t + ; obl_type : types + ; obl_location : Evar_kinds.t Loc.located + ; obl_body : pconstant obligation_body option + ; obl_status : bool * Evar_kinds.obligation_definition_status + ; obl_deps : Int.Set.t + ; obl_tac : unit Proofview.tactic option } + + val set_type : typ:Constr.types -> t -> t + val set_body : body:pconstant obligation_body -> t -> t + +end + +type obligations = + { obls : Obligation.t array + ; remaining : int } type fixpoint_kind = | IsFixpoint of lident option list | IsCoFixpoint -type program_info = - { prg_name : Id.t - ; prg_body : constr - ; prg_type : constr - ; prg_ctx : UState.t - ; prg_univdecl : UState.universe_decl - ; prg_obligations : obligations - ; prg_deps : Id.t list - ; prg_fixkind : fixpoint_kind option - ; prg_implicits : Impargs.manual_implicits - ; prg_notations : Vernacexpr.decl_notation list - ; prg_poly : bool - ; prg_scope : DeclareDef.locality - ; prg_kind : Decls.definition_object_kind - ; prg_reduce : constr -> constr - ; prg_hook : DeclareDef.Hook.t option - ; prg_opaque : bool - } +(* Information about a single [Program {Definition,Lemma,..}] declaration *) +module ProgramDecl : sig + + type t = private + { prg_name : Id.t + ; prg_body : constr + ; prg_type : constr + ; prg_ctx : UState.t + ; prg_univdecl : UState.universe_decl + ; prg_obligations : obligations + ; prg_deps : Id.t list + ; prg_fixkind : fixpoint_kind option + ; prg_implicits : Impargs.manual_implicits + ; prg_notations : Vernacexpr.decl_notation list + ; prg_poly : bool + ; prg_scope : DeclareDef.locality + ; prg_kind : Decls.definition_object_kind + ; prg_reduce : constr -> constr + ; prg_hook : DeclareDef.Hook.t option + ; prg_opaque : bool + } + + val make : + ?opaque:bool + -> ?hook:DeclareDef.Hook.t + -> Names.Id.t + -> udecl:UState.universe_decl + -> uctx:UState.t + -> impargs:Impargs.manual_implicits + -> poly:bool + -> scope:DeclareDef.locality + -> kind:Decls.definition_object_kind + -> Constr.constr option + -> Constr.types + -> Names.Id.t list + -> fixpoint_kind option + -> Vernacexpr.decl_notation list + -> ( Names.Id.t + * Constr.types + * Evar_kinds.t Loc.located + * (bool * Evar_kinds.obligation_definition_status) + * Int.Set.t + * unit Proofview.tactic option ) + array + -> (Constr.constr -> Constr.constr) + -> t + + val set_uctx : uctx:UState.t -> t -> t +end val declare_obligation : - program_info - -> obligation + ProgramDecl.t + -> Obligation.t -> Constr.types -> Constr.types option -> Entries.universes_entry - -> bool * obligation + -> bool * Obligation.t (** [declare_obligation] Save an obligation *) module ProgMap : CMap.ExtS with type key = Id.t and module Set := Id.Set -val declare_definition : program_info -> Names.GlobRef.t +val declare_definition : ProgramDecl.t -> Names.GlobRef.t +(** Resolution status of a program *) type progress = - (* Resolution status of a program *) | Remain of int - (* n obligations remaining *) + (** n obligations remaining *) | Dependent - (* Dependent on other definitions *) + (** Dependent on other definitions *) | Defined of GlobRef.t - (* Defined as id *) + (** Defined as id *) type obligation_qed_info = { name : Id.t @@ -79,32 +119,44 @@ val obligation_terminator : Evd.side_effects Declare.proof_entry list -> UState.t -> obligation_qed_info -> unit -(** [obligation_terminator] part 2 of saving an obligation *) +(** [obligation_terminator] part 2 of saving an obligation, proof mode *) + +val obligation_hook + : ProgramDecl.t + -> Obligation.t + -> Int.t + -> (Names.Id.t option -> Int.Set.t -> 'a option -> 'b) + -> DeclareDef.Hook.S.t + -> unit +(** [obligation_hook] part 2 of saving an obligation, non-interactive mode *) val update_obls : - program_info - -> obligation array + ProgramDecl.t + -> Obligation.t array -> int -> progress (** [update_obls prg obls n progress] What does this do? *) (** { 2 Util } *) -val get_prg_info_map : unit -> program_info CEphemeron.key ProgMap.t +(** Check obligations are properly solved before closing a section *) +val check_can_close : Id.t -> unit + +val get_prg_info_map : unit -> ProgramDecl.t CEphemeron.key ProgMap.t val program_tcc_summary_tag : - program_info CEphemeron.key Id.Map.t Summary.Dyn.tag + ProgramDecl.t CEphemeron.key Id.Map.t Summary.Dyn.tag val obl_substitution : bool - -> obligation array + -> Obligation.t array -> Int.Set.t -> (ProgMap.key * (Constr.types * Constr.types)) list -val dependencies : obligation array -> int -> Int.Set.t +val dependencies : Obligation.t array -> int -> Int.Set.t val err_not_transp : unit -> unit -val progmap_add : ProgMap.key -> program_info CEphemeron.key -> unit +val progmap_add : ProgMap.key -> ProgramDecl.t CEphemeron.key -> unit (* This is a hack to make it possible for Obligations to craft a Qed * behind the scenes. The fix_exn the Stm attaches to the Future proof diff --git a/vernac/egramcoq.ml b/vernac/egramcoq.ml index 1d790e7cd2..fdc8b1ba4c 100644 --- a/vernac/egramcoq.ml +++ b/vernac/egramcoq.ml @@ -325,51 +325,48 @@ let is_binder_level custom (custom',from) e = match e with | _ -> false let make_sep_rules = function - | [tk] -> Atoken tk + | [tk] -> + Pcoq.Symbol.token tk | tkl -> - let rec mkrule : 'a Tok.p list -> 'a rules = function - | [] -> Rules (Stop, fun _ -> (* dropped anyway: *) "") - | tkn :: rem -> - let Rules (r, f) = mkrule rem in - let r = NextNoRec (r, Atoken tkn) in - Rules (r, fun _ -> f) - in - let r = mkrule (List.rev tkl) in - Arules [r] + let r = Pcoq.mk_rule (List.rev tkl) in + Pcoq.Symbol.rules [r] type ('s, 'a) mayrec_symbol = -| MayRecNo : ('s, norec, 'a) symbol -> ('s, 'a) mayrec_symbol -| MayRecMay : ('s, mayrec, 'a) symbol -> ('s, 'a) mayrec_symbol +| MayRecNo : ('s, Gramlib.Grammar.norec, 'a) Symbol.t -> ('s, 'a) mayrec_symbol +| MayRecMay : ('s, Gramlib.Grammar.mayrec, 'a) Symbol.t -> ('s, 'a) mayrec_symbol let symbol_of_target : type s. _ -> _ -> _ -> _ -> s target -> (s, s) mayrec_symbol = fun custom p assoc from forpat -> - if is_binder_level custom from p then (* Prevent self *) MayRecNo (Aentryl (target_entry custom forpat, "200")) - else if is_self custom from p then MayRecMay Aself + if is_binder_level custom from p + then + (* Prevent self *) + MayRecNo (Pcoq.Symbol.nterml (target_entry custom forpat) "200") + else if is_self custom from p then MayRecMay Pcoq.Symbol.self else let g = target_entry custom forpat in let lev = adjust_level custom assoc from p in begin match lev with - | DefaultLevel -> MayRecNo (Aentry g) - | NextLevel -> MayRecMay Anext - | NumLevel lev -> MayRecNo (Aentryl (g, string_of_int lev)) + | DefaultLevel -> MayRecNo (Pcoq.Symbol.nterm g) + | NextLevel -> MayRecMay Pcoq.Symbol.next + | NumLevel lev -> MayRecNo (Pcoq.Symbol.nterml g (string_of_int lev)) end let symbol_of_entry : type s r. _ -> _ -> (s, r) entry -> (s, r) mayrec_symbol = fun assoc from typ -> match typ with | TTConstr (s, p, forpat) -> symbol_of_target s p assoc from forpat | TTConstrList (s, typ', [], forpat) -> begin match symbol_of_target s typ' assoc from forpat with - | MayRecNo s -> MayRecNo (Alist1 s) - | MayRecMay s -> MayRecMay (Alist1 s) end + | MayRecNo s -> MayRecNo (Pcoq.Symbol.list1 s) + | MayRecMay s -> MayRecMay (Pcoq.Symbol.list1 s) end | TTConstrList (s, typ', tkl, forpat) -> begin match symbol_of_target s typ' assoc from forpat with - | MayRecNo s -> MayRecNo (Alist1sep (s, make_sep_rules tkl)) - | MayRecMay s -> MayRecMay (Alist1sep (s, make_sep_rules tkl)) end -| TTPattern p -> MayRecNo (Aentryl (Constr.pattern, string_of_int p)) -| TTClosedBinderList [] -> MayRecNo (Alist1 (Aentry Constr.binder)) -| TTClosedBinderList tkl -> MayRecNo (Alist1sep (Aentry Constr.binder, make_sep_rules tkl)) -| TTName -> MayRecNo (Aentry Prim.name) -| TTOpenBinderList -> MayRecNo (Aentry Constr.open_binders) -| TTBigint -> MayRecNo (Aentry Prim.bigint) -| TTReference -> MayRecNo (Aentry Constr.global) + | MayRecNo s -> MayRecNo (Pcoq.Symbol.list1sep s (make_sep_rules tkl) false) + | MayRecMay s -> MayRecMay (Pcoq.Symbol.list1sep s (make_sep_rules tkl) false) end +| TTPattern p -> MayRecNo (Pcoq.Symbol.nterml Constr.pattern (string_of_int p)) +| TTClosedBinderList [] -> MayRecNo (Pcoq.Symbol.list1 (Pcoq.Symbol.nterm Constr.binder)) +| TTClosedBinderList tkl -> MayRecNo (Pcoq.Symbol.list1sep (Pcoq.Symbol.nterm Constr.binder) (make_sep_rules tkl) false) +| TTName -> MayRecNo (Pcoq.Symbol.nterm Prim.name) +| TTOpenBinderList -> MayRecNo (Pcoq.Symbol.nterm Constr.open_binders) +| TTBigint -> MayRecNo (Pcoq.Symbol.nterm Prim.bignat) +| TTReference -> MayRecNo (Pcoq.Symbol.nterm Constr.global) let interp_entry forpat e = match e with | ETProdName -> TTAny TTName @@ -411,8 +408,8 @@ match e with | TTClosedBinderList _ -> { subst with binderlists = List.flatten v :: subst.binderlists } | TTBigint -> begin match forpat with - | ForConstr -> push_constr subst (CAst.make @@ CPrim (Numeral (SPlus,NumTok.int v))) - | ForPattern -> push_constr subst (CAst.make @@ CPatPrim (Numeral (SPlus,NumTok.int v))) + | ForConstr -> push_constr subst (CAst.make @@ CPrim (Numeral (NumTok.Signed.of_int_string v))) + | ForPattern -> push_constr subst (CAst.make @@ CPatPrim (Numeral (NumTok.Signed.of_int_string v))) end | TTReference -> begin match forpat with @@ -461,22 +458,22 @@ let rec ty_eval : type s a. (s, a, Loc.t -> s) ty_rule -> s gen_eval -> s env -> ty_eval rem f { env with constrs; constrlists; } type ('s, 'a, 'r) mayrec_rule = -| MayRecRNo : ('s, Extend.norec, 'a, 'r) Extend.rule -> ('s, 'a, 'r) mayrec_rule -| MayRecRMay : ('s, Extend.mayrec, 'a, 'r) Extend.rule -> ('s, 'a, 'r) mayrec_rule +| MayRecRNo : ('s, Gramlib.Grammar.norec, 'a, 'r) Rule.t -> ('s, 'a, 'r) mayrec_rule +| MayRecRMay : ('s, Gramlib.Grammar.mayrec, 'a, 'r) Rule.t -> ('s, 'a, 'r) mayrec_rule let rec ty_erase : type s a r. (s, a, r) ty_rule -> (s, a, r) mayrec_rule = function -| TyStop -> MayRecRNo Stop +| TyStop -> MayRecRNo Rule.stop | TyMark (_, _, _, r) -> ty_erase r | TyNext (rem, TyTerm tok) -> begin match ty_erase rem with - | MayRecRNo rem -> MayRecRMay (Next (rem, Atoken tok)) - | MayRecRMay rem -> MayRecRMay (Next (rem, Atoken tok)) end + | MayRecRNo rem -> MayRecRMay (Rule.next rem (Symbol.token tok)) + | MayRecRMay rem -> MayRecRMay (Rule.next rem (Symbol.token tok)) end | TyNext (rem, TyNonTerm (_, _, s, _)) -> begin match ty_erase rem, s with - | MayRecRNo rem, MayRecNo s -> MayRecRMay (Next (rem, s)) - | MayRecRNo rem, MayRecMay s -> MayRecRMay (Next (rem, s)) - | MayRecRMay rem, MayRecNo s -> MayRecRMay (Next (rem, s)) - | MayRecRMay rem, MayRecMay s -> MayRecRMay (Next (rem, s)) end + | MayRecRNo rem, MayRecNo s -> MayRecRMay (Rule.next rem s) + | MayRecRNo rem, MayRecMay s -> MayRecRMay (Rule.next rem s) + | MayRecRMay rem, MayRecNo s -> MayRecRMay (Rule.next rem s) + | MayRecRMay rem, MayRecMay s -> MayRecRMay (Rule.next rem s) end type ('self, 'r) any_ty_rule = | AnyTyRule : ('self, 'act, Loc.t -> 'r) ty_rule -> ('self, 'r) any_ty_rule @@ -504,7 +501,7 @@ let target_to_bool : type r. r target -> bool = function | ForPattern -> true let prepare_empty_levels forpat (where,(pos,p4assoc,name,reinit)) = - let empty = (pos, [(name, p4assoc, [])]) in + let empty = { pos; data = [(name, p4assoc, [])] } in match reinit with | None -> ExtendRule (target_entry where forpat, empty) @@ -522,7 +519,13 @@ let rec pure_sublevels' assoc from forpat level = function let rem = pure_sublevels' assoc from forpat level rem in let push where p rem = match symbol_of_target where p assoc from forpat with - | MayRecNo (Aentryl (_,i)) when different_levels (fst from,level) (where,i) -> (where,int_of_string i) :: rem + | MayRecNo sym -> + (match Pcoq.level_of_nonterm sym with + | None -> rem + | Some i -> + if different_levels (fst from,level) (where,i) then + (where,int_of_string i) :: rem + else rem) | _ -> rem in (match e with | ETProdPattern i -> push InConstrEntry (NumLevel i,InternalProd) rem @@ -553,14 +556,15 @@ let extend_constr state forpat ng = let act = ty_eval r (make_act forpat ng.notgram_notation) empty in let rule = let r = match ty_erase r with - | MayRecRNo symbs -> Rule (symbs, act) - | MayRecRMay symbs -> Rule (symbs, act) in + | MayRecRNo symbs -> Pcoq.Production.make symbs act + | MayRecRMay symbs -> Pcoq.Production.make symbs act + in name, p4assoc, [r] in let r = match reinit with | None -> - ExtendRule (entry, (pos, [rule])) + ExtendRule (entry, { pos; data = [rule]}) | Some reinit -> - ExtendRuleReinit (entry, reinit, (pos, [rule])) + ExtendRuleReinit (entry, reinit, { pos; data = [rule]}) in (accu @ empty_rules @ [r], state) in diff --git a/vernac/egramml.ml b/vernac/egramml.ml index 793aad6b24..bda1401bc9 100644 --- a/vernac/egramml.ml +++ b/vernac/egramml.ml @@ -19,14 +19,14 @@ open Vernacexpr type 's grammar_prod_item = | GramTerminal of string | GramNonTerminal : - ('a raw_abstract_argument_type * ('s, _, 'a) symbol) Loc.located -> 's grammar_prod_item + ('a raw_abstract_argument_type * ('s, _, 'a) Symbol.t) Loc.located -> 's grammar_prod_item type 'a ty_arg = ('a -> raw_generic_argument) type ('self, 'tr, _, 'r) ty_rule = -| TyStop : ('self, Extend.norec, 'r, 'r) ty_rule -| TyNext : ('self, _, 'a, 'r) ty_rule * ('self, _, 'b) Extend.symbol * 'b ty_arg option -> - ('self, Extend.mayrec, 'b -> 'a, 'r) ty_rule +| TyStop : ('self, Gramlib.Grammar.norec, 'r, 'r) ty_rule +| TyNext : ('self, _, 'a, 'r) ty_rule * ('self, _, 'b) Symbol.t * 'b ty_arg option -> + ('self, Gramlib.Grammar.mayrec, 'b -> 'a, 'r) ty_rule type ('self, 'r) any_ty_rule = | AnyTyRule : ('self, _, 'act, Loc.t -> 'r) ty_rule -> ('self, 'r) any_ty_rule @@ -35,7 +35,7 @@ let rec ty_rule_of_gram = function | [] -> AnyTyRule TyStop | GramTerminal s :: rem -> let AnyTyRule rem = ty_rule_of_gram rem in - let tok = Atoken (CLexer.terminal s) in + let tok = Pcoq.Symbol.token (CLexer.terminal s) in let r = TyNext (rem, tok, None) in AnyTyRule r | GramNonTerminal (_, (t, tok)) :: rem -> @@ -44,9 +44,9 @@ let rec ty_rule_of_gram = function let r = TyNext (rem, tok, inj) in AnyTyRule r -let rec ty_erase : type s tr a r. (s, tr, a, r) ty_rule -> (s, tr, a, r) Extend.rule = function -| TyStop -> Extend.Stop -| TyNext (rem, tok, _) -> Extend.Next (ty_erase rem, tok) +let rec ty_erase : type s tr a r. (s, tr, a, r) ty_rule -> (s, tr, a, r) Pcoq.Rule.t = function +| TyStop -> Pcoq.Rule.stop +| TyNext (rem, tok, _) -> Pcoq.Rule.next (ty_erase rem) tok type 'r gen_eval = Loc.t -> raw_generic_argument list -> 'r @@ -62,7 +62,7 @@ let make_rule f prod = let symb = ty_erase ty_rule in let f loc l = f loc (List.rev l) in let act = ty_eval ty_rule f in - Extend.Rule (symb, act) + Pcoq.Production.make symb act let rec proj_symbol : type a b c. (a, b, c) ty_user_symbol -> (a, b, c) genarg_type = function | TUentry a -> ExtraArg a @@ -90,4 +90,4 @@ let extend_vernac_command_grammar s nt gl = vernac_exts := (s,gl) :: !vernac_exts; let mkact loc l = VernacExtend (s, l) in let rules = [make_rule mkact gl] in - grammar_extend nt (None, [None, None, rules]) + grammar_extend nt { pos=None; data=[None, None, rules]} diff --git a/vernac/egramml.mli b/vernac/egramml.mli index 7f6656b079..15f415ca3b 100644 --- a/vernac/egramml.mli +++ b/vernac/egramml.mli @@ -18,7 +18,7 @@ open Vernacexpr type 's grammar_prod_item = | GramTerminal of string | GramNonTerminal : ('a Genarg.raw_abstract_argument_type * - ('s, _, 'a) Extend.symbol) Loc.located -> 's grammar_prod_item + ('s, _, 'a) Pcoq.Symbol.t) Loc.located -> 's grammar_prod_item val extend_vernac_command_grammar : extend_name -> vernac_expr Pcoq.Entry.t option -> @@ -32,4 +32,4 @@ val proj_symbol : ('a, 'b, 'c) Extend.ty_user_symbol -> ('a, 'b, 'c) Genarg.gena val make_rule : (Loc.t -> Genarg.raw_generic_argument list -> 'a) -> - 'a grammar_prod_item list -> 'a Extend.production_rule + 'a grammar_prod_item list -> 'a Pcoq.Production.t diff --git a/vernac/g_vernac.mlg b/vernac/g_vernac.mlg index 77423fbadf..a1cdc718d7 100644 --- a/vernac/g_vernac.mlg +++ b/vernac/g_vernac.mlg @@ -107,35 +107,40 @@ GRAMMAR EXTEND Gram | -> { VernacFlagEmpty } ] ] ; - vernac: - [ [ IDENT "Local"; v = vernac_poly -> { let (f, v) = v in (("local", VernacFlagEmpty) :: f, v) } - | IDENT "Global"; v = vernac_poly -> { let (f, v) = v in (("global", VernacFlagEmpty) :: f, v) } - - | v = vernac_poly -> { v } ] - ] + legacy_attr: + [ [ IDENT "Local" -> + { ("local", VernacFlagEmpty) } + | IDENT "Global" -> + { ("global", VernacFlagEmpty) } + | IDENT "Polymorphic" -> + { Attributes.vernac_polymorphic_flag } + | IDENT "Monomorphic" -> + { Attributes.vernac_monomorphic_flag } + | IDENT "Cumulative" -> + { ("universes", VernacFlagList ["cumulative", VernacFlagEmpty]) } + | IDENT "NonCumulative" -> + { ("universes", VernacFlagList ["noncumulative", VernacFlagEmpty]) } + | IDENT "Private" -> + { ("private", VernacFlagList ["matching", VernacFlagEmpty]) } + | IDENT "Program" -> + { ("program", VernacFlagEmpty) } + ] ] ; - vernac_poly: - [ [ IDENT "Polymorphic"; v = vernac_aux -> - { let (f, v) = v in (Attributes.vernac_polymorphic_flag :: f, v) } - | IDENT "Monomorphic"; v = vernac_aux -> - { let (f, v) = v in (Attributes.vernac_monomorphic_flag :: f, v) } - | v = vernac_aux -> { v } ] - ] + vernac: + [ [ attrs = LIST0 legacy_attr; v = vernac_aux -> { (attrs, v) } ] ] ; vernac_aux: (* Better to parse "." here: in case of failure (e.g. in coerce_to_var), *) (* "." is still in the stream and discard_to_dot works correctly *) - [ [ IDENT "Program"; g = gallina; "." -> { (["program", VernacFlagEmpty], g) } - | IDENT "Program"; g = gallina_ext; "." -> { (["program", VernacFlagEmpty], g) } - | g = gallina; "." -> { ([], g) } - | g = gallina_ext; "." -> { ([], g) } - | c = command; "." -> { ([], c) } - | c = syntax; "." -> { ([], c) } - | c = subprf -> { ([], c) } + [ [ g = gallina; "." -> { g } + | g = gallina_ext; "." -> { g } + | c = command; "." -> { c } + | c = syntax; "." -> { c } + | c = subprf -> { c } ] ] ; vernac_aux: LAST - [ [ prfcom = command_entry -> { ([], prfcom) } ] ] + [ [ prfcom = command_entry -> { prfcom } ] ] ; noedit_mode: [ [ c = query_command -> { c None } ] ] @@ -197,9 +202,8 @@ GRAMMAR EXTEND Gram | IDENT "Let"; id = identref; b = def_body -> { VernacDefinition ((DoDischarge, Let), (lname_of_lident id, None), b) } (* Gallina inductive declarations *) - | cum = OPT cumulativity_token; priv = private_token; f = finite_token; - indl = LIST1 inductive_definition SEP "with" -> - { VernacInductive (cum, priv, f, indl) } + | f = finite_token; indl = LIST1 inductive_definition SEP "with" -> + { VernacInductive (f, indl) } | "Fixpoint"; recs = LIST1 rec_definition SEP "with" -> { VernacFixpoint (NoDischarge, recs) } | IDENT "Let"; "Fixpoint"; recs = LIST1 rec_definition SEP "with" -> @@ -341,35 +345,14 @@ GRAMMAR EXTEND Gram | IDENT "Structure" -> { Structure } | IDENT "Class" -> { Class true } ] ] ; - cumulativity_token: - [ [ IDENT "Cumulative" -> { VernacCumulative } - | IDENT "NonCumulative" -> { VernacNonCumulative } ] ] - ; - private_token: - [ [ IDENT "Private" -> { true } | -> { false } ] ] - ; (* Simple definitions *) def_body: [ [ bl = binders; ":="; red = reduce; c = lconstr -> - { if List.exists (function CLocalPattern _ -> true | _ -> false) bl - then - (* FIXME: "red" will be applied to types in bl and Cast with remain *) - let c = mkLambdaCN ~loc bl c in - DefineBody ([], red, c, None) - else - (match c with - | { CAst.v = CCast(c, CastConv t) } -> DefineBody (bl, red, c, Some t) - | _ -> DefineBody (bl, red, c, None)) } + { match c.CAst.v with + | CCast(c, Glob_term.CastConv t) -> DefineBody (bl, red, c, Some t) + | _ -> DefineBody (bl, red, c, None) } | bl = binders; ":"; t = lconstr; ":="; red = reduce; c = lconstr -> - { let ((bl, c), tyo) = - if List.exists (function CLocalPattern _ -> true | _ -> false) bl - then - (* FIXME: "red" will be applied to types in bl and Cast with remain *) - let c = CAst.make ~loc @@ CCast (c, CastConv t) in - (([],mkLambdaCN ~loc bl c), None) - else ((bl, c), Some t) - in - DefineBody (bl, red, c, tyo) } + { DefineBody (bl, red, c, Some t) } | bl = binders; ":"; t = lconstr -> { ProveBody (bl, t) } ] ] ; @@ -986,13 +969,6 @@ GRAMMAR EXTEND Gram { fun g -> VernacSearch (SearchRewrite c,g, l) } | IDENT "Search"; s = searchabout_query; l = searchabout_queries; "." -> { let (sl,m) = l in fun g -> VernacSearch (Search (s::sl),g, m) } - (* compatibility: SearchAbout *) - | IDENT "SearchAbout"; s = searchabout_query; l = searchabout_queries; "." -> - { fun g -> let (sl,m) = l in VernacSearch (SearchAbout (s::sl),g, m) } - (* compatibility: SearchAbout with "[ ... ]" *) - | IDENT "SearchAbout"; "["; sl = LIST1 searchabout_query; "]"; - l = in_or_out_modules; "." -> - { fun g -> VernacSearch (SearchAbout sl,g, l) } ] ] ; printable: diff --git a/vernac/lemmas.ml b/vernac/lemmas.ml index c2cf7a5ec4..feedf4d71d 100644 --- a/vernac/lemmas.ml +++ b/vernac/lemmas.ml @@ -27,47 +27,34 @@ module Proof_ending = struct | Regular | End_obligation of DeclareObl.obligation_qed_info | End_derive of { f : Id.t; name : Id.t } - | End_equations of { hook : Constant.t list -> Evd.evar_map -> unit - ; i : Id.t - ; types : (Environ.env * Evar.t * Evd.evar_info * EConstr.named_context * Evd.econstr) list - ; wits : EConstr.t list ref - (* wits are actually computed by the proof - engine by side-effect after creating the - proof! This is due to the start_dependent_proof API *) - ; sigma : Evd.evar_map - } + | End_equations of + { hook : Constant.t list -> Evd.evar_map -> unit + ; i : Id.t + ; types : (Environ.env * Evar.t * Evd.evar_info * EConstr.named_context * Evd.econstr) list + ; sigma : Evd.evar_map + } end -module Recthm = struct - type t = - { name : Id.t - ; typ : Constr.t - ; args : Name.t list - ; impargs : Impargs.manual_implicits - } -end - module Info = struct type t = { hook : DeclareDef.Hook.t option - ; compute_guard : lemma_possible_guards - ; impargs : Impargs.manual_implicits ; proof_ending : Proof_ending.t CEphemeron.key (* This could be improved and the CEphemeron removed *) - ; other_thms : Recthm.t list ; scope : DeclareDef.locality ; kind : Decls.logical_kind + (* thms and compute guard are specific only to start_lemma_with_initialization + regular terminator *) + ; thms : DeclareDef.Recthm.t list + ; compute_guard : lemma_possible_guards } let make ?hook ?(proof_ending=Proof_ending.Regular) ?(scope=DeclareDef.Global Declare.ImportDefaultBehavior) ?(kind=Decls.(IsProof Lemma)) () = { hook ; compute_guard = [] - ; impargs = [] ; proof_ending = CEphemeron.create proof_ending - ; other_thms = [] + ; thms = [] ; scope ; kind } @@ -109,18 +96,30 @@ let initialize_named_context_for_proof () = let d = if Decls.variable_opacity id then NamedDecl.drop_body d else d in Environ.push_named_context_val d signv) sign Environ.empty_named_context_val +let add_first_thm ~info ~name ~typ ~impargs = + let thms = + { DeclareDef.Recthm.name + ; impargs + ; typ = EConstr.Unsafe.to_constr typ + ; args = [] } :: info.Info.thms + in + { info with Info.thms } + (* Starting a goal *) let start_lemma ~name ~poly ?(udecl=UState.default_univ_decl) - ?(info=Info.make ()) - sigma c = + ?(info=Info.make ()) ?(impargs=[]) sigma c = (* We remove the bodies of variables in the named context marked "opaque", this is a hack tho, see #10446 *) let sign = initialize_named_context_for_proof () in let goals = [ Global.env_of_context sign , c ] in let proof = Proof_global.start_proof sigma ~name ~udecl ~poly goals in - { proof ; info } + let info = add_first_thm ~info ~name ~typ:c ~impargs in + { proof; info } +(* Note that proofs opened by start_dependent lemma cannot be closed + by the regular terminators, thus we don't need to update the [thms] + field. We will capture this invariant by typing in the future *) let start_dependent_lemma ~name ~poly ?(udecl=UState.default_univ_decl) ?(info=Info.make ()) telescope = @@ -129,7 +128,7 @@ let start_dependent_lemma ~name ~poly let rec_tac_initializer finite guard thms snl = if finite then - match List.map (fun { Recthm.name; typ } -> name, (EConstr.of_constr typ)) thms with + match List.map (fun { DeclareDef.Recthm.name; typ } -> name, (EConstr.of_constr typ)) thms with | (id,_)::l -> Tactics.mutual_cofix id l 0 | _ -> assert false else @@ -137,42 +136,45 @@ let rec_tac_initializer finite guard thms snl = let nl = match snl with | None -> List.map succ (List.map List.last guard) | Some nl -> nl - in match List.map2 (fun { Recthm.name; typ } n -> (name, n, (EConstr.of_constr typ))) thms nl with + in match List.map2 (fun { DeclareDef.Recthm.name; typ } n -> (name, n, (EConstr.of_constr typ))) thms nl with | (id,n,_)::l -> Tactics.mutual_fix id n l 0 | _ -> assert false let start_lemma_with_initialization ?hook ~poly ~scope ~kind ~udecl sigma recguard thms snl = - let intro_tac { Recthm.args; _ } = Tactics.auto_intros_tac args in + let intro_tac { DeclareDef.Recthm.args; _ } = Tactics.auto_intros_tac args in let init_tac, compute_guard = match recguard with - | Some (finite,guard,init_tac) -> + | Some (finite,guard,init_terms) -> let rec_tac = rec_tac_initializer finite guard thms snl in - Some (match init_tac with - | None -> - Tacticals.New.tclTHENS rec_tac (List.map intro_tac thms) - | Some tacl -> - Tacticals.New.tclTHENS rec_tac - List.(map2 (fun tac thm -> Tacticals.New.tclTHEN tac (intro_tac thm)) tacl thms) - ),guard + let term_tac = + match init_terms with + | None -> + List.map intro_tac thms + | Some init_terms -> + (* This is the case for hybrid proof mode / definition + fixpoint, where terms for some constants are given with := *) + let tacl = List.map (Option.cata (EConstr.of_constr %> Tactics.exact_no_check) Tacticals.New.tclIDTAC) init_terms in + List.map2 (fun tac thm -> Tacticals.New.tclTHEN tac (intro_tac thm)) tacl thms + in + Tacticals.New.tclTHENS rec_tac term_tac, guard | None -> let () = match thms with [_] -> () | _ -> assert false in - Some (intro_tac (List.hd thms)), [] in + intro_tac (List.hd thms), [] in match thms with | [] -> CErrors.anomaly (Pp.str "No proof to start.") - | { Recthm.name; typ; impargs; _}::other_thms -> + | { DeclareDef.Recthm.name; typ; impargs; _} :: thms -> let info = Info.{ hook - ; impargs ; compute_guard - ; other_thms ; proof_ending = CEphemeron.create Proof_ending.Regular + ; thms ; scope ; kind } in - let lemma = start_lemma ~name ~poly ~udecl ~info sigma (EConstr.of_constr typ) in + (* start_lemma has the responsibility to add (name, impargs, typ) + to thms, once Info.t is more refined this won't be necessary *) + let lemma = start_lemma ~name ~impargs ~poly ~udecl ~info sigma (EConstr.of_constr typ) in pf_map (Proof_global.map_proof (fun p -> - match init_tac with - | None -> p - | Some tac -> pi1 @@ Proof.run_tactic Global.(env ()) tac p)) lemma + pi1 @@ Proof.run_tactic Global.(env ()) init_tac p)) lemma (************************************************************************) (* Commom constant saving path, for both Qed and Admitted *) @@ -183,46 +185,22 @@ let start_lemma_with_initialization ?hook ~poly ~scope ~kind ~udecl sigma recgua (* XXX: Most of this does belong to Declare, due to proof_entry manip *) module MutualEntry : sig - (* We keep this type abstract and to avoid uncontrolled hacks *) - type t - - val variable : info:Info.t -> Entries.parameter_entry -> t - - val adjust_guardness_conditions + val declare_variable : info:Info.t - -> Evd.side_effects Declare.proof_entry - -> t + -> uctx:UState.t + -> Entries.parameter_entry + -> Names.GlobRef.t list val declare_mutdef (* Common to all recthms *) - : ?fix_exn:(Exninfo.iexn -> Exninfo.iexn) - -> poly:bool + : info:Info.t -> uctx:UState.t - -> ?hook_data:DeclareDef.Hook.t * UState.t * (Names.Id.t * Constr.t) list - -> udecl:UState.universe_decl - (* Only for the first constant, introduced by compat *) - -> ubind:UnivNames.universe_binders - -> name:Id.t - -> t + -> Evd.side_effects Declare.proof_entry -> Names.GlobRef.t list end = struct - (* Body with the fix *) - type et = - | NoBody of Entries.parameter_entry - | Single of Evd.side_effects Declare.proof_entry - | Mutual of Evd.side_effects Declare.proof_entry - - type t = - { entry : et - ; info : Info.t - } - - let variable ~info t = { entry = NoBody t; info } - - (* XXX: Refactor this with the code in - [ComFixpoint.declare_fixpoint_generic] *) + (* XXX: Refactor this with the code in [DeclareDef.declare_mutdef] *) let guess_decreasing env possible_indexes ((body, ctx), eff) = let open Constr in match Constr.kind body with @@ -232,66 +210,56 @@ end = struct (mkFix ((indexes,0),fixdecls), ctx), eff | _ -> (body, ctx), eff - let adjust_guardness_conditions ~info const = - let entry = match info.Info.compute_guard with - | [] -> - (* Not a recursive statement *) - Single const - | possible_indexes -> - (* Try all combinations... not optimal *) - let env = Global.env() in - let pe = Declare.Internal.map_entry_body const - ~f:(guess_decreasing env possible_indexes) - in - Mutual pe - in { entry; info } - - let rec select_body i t = + let select_body i t = let open Constr in match Constr.kind t with | Fix ((nv,0),decls) -> mkFix ((nv,i),decls) | CoFix (0,decls) -> mkCoFix (i,decls) - | LetIn(na,t1,ty,t2) -> mkLetIn (na,t1,ty, select_body i t2) - | Lambda(na,ty,t) -> mkLambda(na,ty, select_body i t) - | App (t, args) -> mkApp (select_body i t, args) | _ -> CErrors.anomaly Pp.(str "Not a proof by induction: " ++ Termops.Internal.debug_print_constr (EConstr.of_constr t) ++ str ".") - let declare_mutdef ?fix_exn ~poly ~uctx ?hook_data ~udecl ~ubind ~name ?typ ~impargs ~info mutpe i = - let { Info.hook; compute_guard; scope; kind; _ } = info in - match mutpe with - | NoBody pe -> - DeclareDef.declare_assumption ?fix_exn ~name ~scope ~hook ~impargs ~uctx pe - | Single pe -> - (* We'd like to do [assert (i = 0)] here, however this codepath - is used when declaring mutual cofixpoints *) - DeclareDef.declare_definition ~name ~scope ~kind ?hook_data ubind pe impargs - | Mutual pe -> - (* if typ = None , we don't touch the type; used in the base case *) - let pe = - match typ with - | None -> pe - | Some typ -> - Declare.Internal.map_entry_type pe ~f:(fun _ -> Some typ) - in - let pe = Declare.Internal.map_entry_body pe - ~f:(fun ((body, ctx), eff) -> (select_body i body, ctx), eff) in - DeclareDef.declare_definition ~name ~scope ~kind ?hook_data ubind pe impargs - - let declare_mutdef ?fix_exn ~poly ~uctx ?hook_data ~udecl ~ubind ~name { entry; info } = - (* At some point make this a single iteration *) - (* impargs here are special too, fixed in upcoming PRs *) - let impargs = info.Info.impargs in - let r = declare_mutdef ?fix_exn ~poly ~info ~udecl ~ubind ?hook_data ~uctx ~name ~impargs entry 0 in - (* Before we used to do this, check if that's right *) - let ubind = UnivNames.empty_binders in - let rs = - List.map_i ( - fun i { Recthm.name; typ; impargs } -> - declare_mutdef ?fix_exn ~poly ~udecl ~info ~ubind ?hook_data ~uctx ~name ~typ ~impargs entry i) 1 info.Info.other_thms - in r :: rs + let declare_mutdef ~uctx ~info pe i DeclareDef.Recthm.{ name; impargs; typ; _} = + let { Info.hook; scope; kind; compute_guard; _ } = info in + (* if i = 0 , we don't touch the type; this is for compat + but not clear it is the right thing to do. + *) + let pe, ubind = + if i > 0 && not (CList.is_empty compute_guard) + then Declare.Internal.map_entry_type pe ~f:(fun _ -> Some typ), UnivNames.empty_binders + else pe, UState.universe_binders uctx + in + (* We when compute_guard was [] in the previous step we should not + substitute the body *) + let pe = match compute_guard with + | [] -> pe + | _ -> + Declare.Internal.map_entry_body pe + ~f:(fun ((body, ctx), eff) -> (select_body i body, ctx), eff) + in + DeclareDef.declare_entry ~name ~scope ~kind ?hook ~impargs ~uctx pe + + let declare_mutdef ~info ~uctx const = + let pe = match info.Info.compute_guard with + | [] -> + (* Not a recursive statement *) + const + | possible_indexes -> + (* Try all combinations... not optimal *) + let env = Global.env() in + Declare.Internal.map_entry_body const + ~f:(guess_decreasing env possible_indexes) + in + List.map_i (declare_mutdef ~info ~uctx pe) 0 info.Info.thms + + let declare_variable ~info ~uctx pe = + let { Info.scope; hook } = info in + List.map_i ( + fun i { DeclareDef.Recthm.name; typ; impargs } -> + DeclareDef.declare_assumption ~name ~scope ~hook ~impargs ~uctx pe + ) 0 info.Info.thms + end (************************************************************************) @@ -318,16 +286,13 @@ let compute_proof_using_for_admitted proof typ pproofs = Some (Environ.really_needed env (Id.Set.union ids_typ ids_def)) | _ -> None -let finish_admitted ~name ~poly ~info ~uctx ~udecl pe = - let mutpe = MutualEntry.variable ~info pe in - let ubind = UnivNames.empty_binders in - let _r : Names.GlobRef.t list = - MutualEntry.declare_mutdef ~uctx ~poly ~udecl ~ubind ~name mutpe in +let finish_admitted ~info ~uctx pe = + let _r : Names.GlobRef.t list = MutualEntry.declare_variable ~info ~uctx pe in () let save_lemma_admitted ~(lemma : t) : unit = let udecl = Proof_global.get_universe_decl lemma.proof in - let Proof.{ name; poly; entry } = Proof.data (Proof_global.get_proof lemma.proof) in + let Proof.{ poly; entry } = Proof.data (Proof_global.get_proof lemma.proof) in let typ = match Proofview.initial_goals entry with | [typ] -> snd typ | _ -> CErrors.anomaly ~label:"Lemmas.save_lemma_admitted" (Pp.str "more than one statement.") @@ -336,49 +301,26 @@ let save_lemma_admitted ~(lemma : t) : unit = let proof = Proof_global.get_proof lemma.proof in let pproofs = Proof.partial_proof proof in let sec_vars = compute_proof_using_for_admitted lemma.proof typ pproofs in - let universes = Proof_global.get_initial_euctx lemma.proof in - let ctx = UState.check_univ_decl ~poly universes udecl in - finish_admitted ~name ~poly ~info:lemma.info ~uctx:universes ~udecl (sec_vars, (typ, ctx), None) + let uctx = Proof_global.get_initial_euctx lemma.proof in + let univs = UState.check_univ_decl ~poly uctx udecl in + finish_admitted ~info:lemma.info ~uctx (sec_vars, (typ, univs), None) (************************************************************************) (* Saving a lemma-like constant *) (************************************************************************) -let default_thm_id = Id.of_string "Unnamed_thm" - -let check_anonymity id save_ident = - if not (String.equal (Nameops.atompart_of_id id) (Id.to_string (default_thm_id))) then - CErrors.user_err Pp.(str "This command can only be used for unnamed theorem.") - -let finish_proved idopt po info = +let finish_proved po info = let open Proof_global in - let { Info.hook } = info in match po with - | { name; entries=[const]; universes; udecl; poly } -> - let name = match idopt with - | None -> name - | Some { CAst.v = save_id } -> check_anonymity name save_id; save_id in - let fix_exn = Declare.Internal.get_fix_exn const in - let () = try - let mutpe = MutualEntry.adjust_guardness_conditions ~info const in - let hook_data = Option.map (fun hook -> hook, universes, []) hook in - let ubind = UState.universe_binders universes in - let _r : Names.GlobRef.t list = - MutualEntry.declare_mutdef ~fix_exn ~uctx:universes ~poly ~udecl ?hook_data ~ubind ~name mutpe - in () - with e when CErrors.noncritical e -> - let e = Exninfo.capture e in - Exninfo.iraise (fix_exn e) - in () + | { entries=[const]; uctx } -> + let _r : Names.GlobRef.t list = MutualEntry.declare_mutdef ~info ~uctx const in + () | _ -> CErrors.anomaly ~label:"finish_proved" Pp.(str "close_proof returned more than one proof term") -let finish_derived ~f ~name ~idopt ~entries = +let finish_derived ~f ~name ~entries = (* [f] and [name] correspond to the proof of [f] and of [suchthat], respectively. *) - if Option.has_some idopt then - CErrors.user_err Pp.(str "Cannot save a proof of Derive with an explicit name."); - let f_def, lemma_def = match entries with | [_;f_def;lemma_def] -> @@ -411,11 +353,11 @@ let finish_derived ~f ~name ~idopt ~entries = let _ : Names.Constant.t = Declare.declare_constant ~name ~kind:Decls.(IsProof Proposition) lemma_def in () -let finish_proved_equations lid kind proof_obj hook i types wits sigma0 = +let finish_proved_equations ~kind ~hook i proof_obj types sigma0 = let obls = ref 1 in let sigma, recobls = - CList.fold_left2_map (fun sigma (wit, (evar_env, ev, evi, local_context, type_)) entry -> + CList.fold_left2_map (fun sigma (_evar_env, ev, _evi, local_context, _type) entry -> let id = match Evd.evar_ident ev sigma0 with | Some id -> id @@ -426,34 +368,51 @@ let finish_proved_equations lid kind proof_obj hook i types wits sigma0 = let sigma, app = Evarutil.new_global sigma (GlobRef.ConstRef cst) in let sigma = Evd.define ev (EConstr.applist (app, List.map EConstr.of_constr args)) sigma in sigma, cst) sigma0 - (CList.combine (List.rev !wits) types) proof_obj.Proof_global.entries + types proof_obj.Proof_global.entries in hook recobls sigma -let finalize_proof idopt proof_obj proof_info = +let finalize_proof proof_obj proof_info = let open Proof_global in let open Proof_ending in match CEphemeron.default proof_info.Info.proof_ending Regular with | Regular -> - finish_proved idopt proof_obj proof_info + finish_proved proof_obj proof_info | End_obligation oinfo -> - DeclareObl.obligation_terminator proof_obj.entries proof_obj.universes oinfo + DeclareObl.obligation_terminator proof_obj.entries proof_obj.uctx oinfo | End_derive { f ; name } -> - finish_derived ~f ~name ~idopt ~entries:proof_obj.entries - | End_equations { hook; i; types; wits; sigma } -> - finish_proved_equations idopt proof_info.Info.kind proof_obj hook i types wits sigma + finish_derived ~f ~name ~entries:proof_obj.entries + | End_equations { hook; i; types; sigma } -> + finish_proved_equations ~kind:proof_info.Info.kind ~hook i proof_obj types sigma + +let err_save_forbidden_in_place_of_qed () = + CErrors.user_err (Pp.str "Cannot use Save with more than one constant or in this proof mode") + +let process_idopt_for_save ~idopt info = + match idopt with + | None -> info + | Some { CAst.v = save_name } -> + (* Save foo was used; we override the info in the first theorem *) + let thms = + match info.Info.thms, CEphemeron.default info.Info.proof_ending Proof_ending.Regular with + | [ { DeclareDef.Recthm.name; _} as decl ], Proof_ending.Regular -> + [ { decl with DeclareDef.Recthm.name = save_name } ] + | _ -> + err_save_forbidden_in_place_of_qed () + in { info with Info.thms } let save_lemma_proved ~lemma ~opaque ~idopt = (* Env and sigma are just used for error printing in save_remaining_recthms *) let proof_obj = Proof_global.close_proof ~opaque ~keep_body_ucst_separate:false (fun x -> x) lemma.proof in - finalize_proof idopt proof_obj lemma.info + let proof_info = process_idopt_for_save ~idopt lemma.info in + finalize_proof proof_obj proof_info (***********************************************************************) (* Special case to close a lemma without forcing a proof *) (***********************************************************************) let save_lemma_admitted_delayed ~proof ~info = let open Proof_global in - let { name; entries; universes; udecl; poly } = proof in + let { entries; uctx } = proof in if List.length entries <> 1 then CErrors.user_err Pp.(str "Admitted does not support multiple statements"); let { Declare.proof_entry_secctx; proof_entry_type; proof_entry_universes } = List.hd entries in @@ -463,8 +422,16 @@ let save_lemma_admitted_delayed ~proof ~info = let typ = match proof_entry_type with | None -> CErrors.user_err Pp.(str "Admitted requires an explicit statement"); | Some typ -> typ in - let ctx = UState.univ_entry ~poly universes in + let ctx = UState.univ_entry ~poly uctx in let sec_vars = if get_keep_admitted_vars () then proof_entry_secctx else None in - finish_admitted ~name ~poly ~uctx:universes ~udecl ~info (sec_vars, (typ, ctx), None) - -let save_lemma_proved_delayed ~proof ~info ~idopt = finalize_proof idopt proof info + finish_admitted ~uctx ~info (sec_vars, (typ, ctx), None) + +let save_lemma_proved_delayed ~proof ~info ~idopt = + (* vio2vo calls this but with invalid info, we have to workaround + that to add the name to the info structure *) + if CList.is_empty info.Info.thms then + let info = add_first_thm ~info ~name:proof.Proof_global.name ~typ:EConstr.mkSet ~impargs:[] in + finalize_proof proof info + else + let info = process_idopt_for_save ~idopt info in + finalize_proof proof info diff --git a/vernac/lemmas.mli b/vernac/lemmas.mli index 79fdfe37de..8a23daa85f 100644 --- a/vernac/lemmas.mli +++ b/vernac/lemmas.mli @@ -35,28 +35,15 @@ module Proof_ending : sig | Regular | End_obligation of DeclareObl.obligation_qed_info | End_derive of { f : Id.t; name : Id.t } - | End_equations of { hook : Constant.t list -> Evd.evar_map -> unit - ; i : Id.t - ; types : (Environ.env * Evar.t * Evd.evar_info * EConstr.named_context * Evd.econstr) list - ; wits : EConstr.t list ref - ; sigma : Evd.evar_map - } + | End_equations of + { hook : Constant.t list -> Evd.evar_map -> unit + ; i : Id.t + ; types : (Environ.env * Evar.t * Evd.evar_info * EConstr.named_context * Evd.econstr) list + ; sigma : Evd.evar_map + } end -module Recthm : sig - type t = - { name : Id.t - (** Name of theorem *) - ; typ : Constr.t - (** Type of theorem *) - ; args : Name.t list - (** Names to pre-introduce *) - ; impargs : Impargs.manual_implicits - (** Explicitily declared implicit arguments *) - } -end - module Info : sig type t @@ -81,6 +68,7 @@ val start_lemma -> poly:bool -> ?udecl:UState.universe_decl -> ?info:Info.t + -> ?impargs:Impargs.manual_implicits -> Evd.evar_map -> EConstr.types -> t @@ -95,7 +83,7 @@ val start_dependent_lemma type lemma_possible_guards = int list list -(** Pretty much internal, only used in ComFixpoint *) +(** Pretty much internal, used by the Lemma / Fixpoint vernaculars *) val start_lemma_with_initialization : ?hook:DeclareDef.Hook.t -> poly:bool @@ -103,13 +91,11 @@ val start_lemma_with_initialization -> kind:Decls.logical_kind -> udecl:UState.universe_decl -> Evd.evar_map - -> (bool * lemma_possible_guards * unit Proofview.tactic list option) option - -> Recthm.t list + -> (bool * lemma_possible_guards * Constr.t option list option) option + -> DeclareDef.Recthm.t list -> int list option -> t -val default_thm_id : Names.Id.t - (** {4 Saving proofs} *) val save_lemma_admitted : lemma:t -> unit diff --git a/vernac/library.ml b/vernac/library.ml index 85645b92d4..7c629b08e7 100644 --- a/vernac/library.ml +++ b/vernac/library.ml @@ -103,17 +103,13 @@ type library_summary = { libsum_digests : Safe_typing.vodigest; } -module LibraryOrdered = DirPath -module LibraryMap = Map.Make(LibraryOrdered) -module LibraryFilenameMap = Map.Make(LibraryOrdered) - (* This is a map from names to loaded libraries *) -let libraries_table : library_summary LibraryMap.t ref = - Summary.ref LibraryMap.empty ~name:"LIBRARY" +let libraries_table : library_summary DPmap.t ref = + Summary.ref DPmap.empty ~name:"LIBRARY" (* This is the map of loaded libraries filename *) (* (not synchronized so as not to be caught in the states on disk) *) -let libraries_filename_table = ref LibraryFilenameMap.empty +let libraries_filename_table = ref DPmap.empty (* These are the _ordered_ sets of loaded, imported and exported libraries *) let libraries_loaded_list = Summary.ref [] ~name:"LIBRARY-LOAD" @@ -121,7 +117,7 @@ let libraries_loaded_list = Summary.ref [] ~name:"LIBRARY-LOAD" (* various requests to the tables *) let find_library dir = - LibraryMap.find dir !libraries_table + DPmap.find dir !libraries_table let try_find_library dir = try find_library dir @@ -133,16 +129,16 @@ let register_library_filename dir f = (* Not synchronized: overwrite the previous binding if one existed *) (* from a previous play of the session *) libraries_filename_table := - LibraryFilenameMap.add dir f !libraries_filename_table + DPmap.add dir f !libraries_filename_table let library_full_filename dir = - try LibraryFilenameMap.find dir !libraries_filename_table + try DPmap.find dir !libraries_filename_table with Not_found -> "<unavailable filename>" let overwrite_library_filenames f = let f = if Filename.is_relative f then Filename.concat (Sys.getcwd ()) f else f in - LibraryMap.iter (fun dir _ -> register_library_filename dir f) + DPmap.iter (fun dir _ -> register_library_filename dir f) !libraries_table let library_is_loaded dir = @@ -167,7 +163,7 @@ let register_loaded_library m = | m'::_ as l when DirPath.equal m' libname -> l | m'::l' -> m' :: aux l' in libraries_loaded_list := aux !libraries_loaded_list; - libraries_table := LibraryMap.add libname m !libraries_table + libraries_table := DPmap.add libname m !libraries_table let loaded_libraries () = !libraries_loaded_list @@ -187,13 +183,13 @@ type 'a table_status = | Fetched of 'a array let opaque_tables = - ref (LibraryMap.empty : (Opaqueproof.opaque_proofterm table_status) LibraryMap.t) + ref (DPmap.empty : (Opaqueproof.opaque_proofterm table_status) DPmap.t) let add_opaque_table dp st = - opaque_tables := LibraryMap.add dp st !opaque_tables + opaque_tables := DPmap.add dp st !opaque_tables let access_table what tables dp i = - let t = match LibraryMap.find dp !tables with + let t = match DPmap.find dp !tables with | Fetched t -> t | ToFetch f -> let dir_path = Names.DirPath.to_string dp in @@ -206,7 +202,7 @@ let access_table what tables dp i = str ") is inaccessible or corrupted,\ncannot load some " ++ str what ++ str " in it.\n") in - tables := LibraryMap.add dp (Fetched t) !tables; + tables := DPmap.add dp (Fetched t) !tables; t in assert (i < Array.length t); t.(i) @@ -261,14 +257,12 @@ let intern_from_file f = | Some (_,false) -> mk_library lsd lmd (Dvo_or_vi digest_lmd) Univ.ContextSet.empty -module DPMap = Map.Make(DirPath) - let rec intern_library ~lib_resolver (needed, contents) (dir, f) from = (* Look if in the current logical environment *) try (find_library dir).libsum_digests, (needed, contents) with Not_found -> (* Look if already listed and consequently its dependencies too *) - try (DPMap.find dir contents).library_digests, (needed, contents) + try (DPmap.find dir contents).library_digests, (needed, contents) with Not_found -> Feedback.feedback(Feedback.FileDependency (from, DirPath.to_string dir)); (* [dir] is an absolute name which matches [f] which must be in loadpath *) @@ -286,7 +280,7 @@ and intern_library_deps ~lib_resolver libs dir m from = let needed, contents = Array.fold_left (intern_mandatory_library ~lib_resolver dir from) libs m.library_deps in - (dir :: needed, DPMap.add dir m contents ) + (dir :: needed, DPmap.add dir m contents ) and intern_mandatory_library ~lib_resolver caller from libs (dir,d) = let digest, libs = intern_library ~lib_resolver libs (dir, None) (Some from) in @@ -372,8 +366,8 @@ let warn_require_in_module = strbrk "and optionally Import it inside another one.") let require_library_from_dirpath ~lib_resolver modrefl export = - let needed, contents = List.fold_left (rec_intern_library ~lib_resolver) ([], DPMap.empty) modrefl in - let needed = List.rev_map (fun dir -> DPMap.find dir contents) needed in + let needed, contents = List.fold_left (rec_intern_library ~lib_resolver) ([], DPmap.empty) modrefl in + let needed = List.rev_map (fun dir -> DPmap.find dir contents) needed in let modrefl = List.map fst modrefl in if Lib.is_module_or_modtype () then begin @@ -500,14 +494,11 @@ let save_library_to todo_proofs ~output_native_objects dir f otab = let save_library_raw f sum lib univs proofs = save_library_base f sum lib (Some univs) None proofs -module StringOrd = struct type t = string let compare = String.compare end -module StringSet = Set.Make(StringOrd) - let get_used_load_paths () = - StringSet.elements - (List.fold_left (fun acc m -> StringSet.add + String.Set.elements + (List.fold_left (fun acc m -> String.Set.add (Filename.dirname (library_full_filename m)) acc) - StringSet.empty !libraries_loaded_list) + String.Set.empty !libraries_loaded_list) let _ = Nativelib.get_load_paths := get_used_load_paths diff --git a/vernac/metasyntax.ml b/vernac/metasyntax.ml index 22e4e35ad4..475d5c31f7 100644 --- a/vernac/metasyntax.ml +++ b/vernac/metasyntax.ml @@ -252,7 +252,7 @@ let quote_notation_token x = let is_numeral symbs = match List.filter (function Break _ -> false | _ -> true) symbs with | ([Terminal "-"; Terminal x] | [Terminal x]) -> - NumTok.of_string x <> None + NumTok.Unsigned.parse_string x <> None | _ -> false diff --git a/vernac/obligations.ml b/vernac/obligations.ml index d6ce1036b9..435085793c 100644 --- a/vernac/obligations.ml +++ b/vernac/obligations.ml @@ -10,253 +10,15 @@ open Printf -(** - - Get types of existentials ; - - Flatten dependency tree (prefix order) ; - - Replace existentials by de Bruijn indices in term, applied to the right arguments ; - - Apply term prefixed by quantification on "existentials". -*) - -open Term -open Constr -open Vars open Names -open Evd open Pp open CErrors open Util -module NamedDecl = Context.Named.Declaration - +(* For the records fields, opens should go away one these types are private *) open DeclareObl - -let succfix (depth, fixrels) = - (succ depth, List.map succ fixrels) - -let check_evars env evm = - Evar.Map.iter - (fun key evi -> - if Evd.is_obligation_evar evm key then () - else - let (loc,k) = evar_source key evm in - Pretype_errors.error_unsolvable_implicit ?loc env evm key None) - (Evd.undefined_map evm) - -type oblinfo = - { ev_name: int * Id.t; - ev_hyps: EConstr.named_context; - ev_status: bool * Evar_kinds.obligation_definition_status; - ev_chop: int option; - ev_src: Evar_kinds.t Loc.located; - ev_typ: types; - ev_tac: unit Proofview.tactic option; - ev_deps: Int.Set.t } - -(** Substitute evar references in t using de Bruijn indices, - where n binders were passed through. *) - -let subst_evar_constr evm evs n idf t = - let seen = ref Int.Set.empty in - let transparent = ref Id.Set.empty in - let evar_info id = List.assoc_f Evar.equal id evs in - let rec substrec (depth, fixrels) c = match EConstr.kind evm c with - | Evar (k, args) -> - let { ev_name = (id, idstr) ; - ev_hyps = hyps ; ev_chop = chop } = - try evar_info k - with Not_found -> - anomaly ~label:"eterm" (Pp.str "existential variable " ++ int (Evar.repr k) ++ str " not found.") - in - seen := Int.Set.add id !seen; - (* Evar arguments are created in inverse order, - and we must not apply to defined ones (i.e. LetIn's) - *) - let args = - let n = match chop with None -> 0 | Some c -> c in - let (l, r) = List.chop n (List.rev (Array.to_list args)) in - List.rev r - in - let args = - let rec aux hyps args acc = - let open Context.Named.Declaration in - match hyps, args with - (LocalAssum _ :: tlh), (c :: tla) -> - aux tlh tla ((substrec (depth, fixrels) c) :: acc) - | (LocalDef _ :: tlh), (_ :: tla) -> - aux tlh tla acc - | [], [] -> acc - | _, _ -> acc (*failwith "subst_evars: invalid argument"*) - in aux hyps args [] - in - if List.exists - (fun x -> match EConstr.kind evm x with - | Rel n -> Int.List.mem n fixrels - | _ -> false) args - then - transparent := Id.Set.add idstr !transparent; - EConstr.mkApp (idf idstr, Array.of_list args) - | Fix _ -> - EConstr.map_with_binders evm succfix substrec (depth, 1 :: fixrels) c - | _ -> EConstr.map_with_binders evm succfix substrec (depth, fixrels) c - in - let t' = substrec (0, []) t in - EConstr.to_constr evm t', !seen, !transparent - - -(** Substitute variable references in t using de Bruijn indices, - where n binders were passed through. *) -let subst_vars acc n t = - let var_index id = Util.List.index Id.equal id acc in - let rec substrec depth c = match Constr.kind c with - | Var v -> (try mkRel (depth + (var_index v)) with Not_found -> c) - | _ -> Constr.map_with_binders succ substrec depth c - in - substrec 0 t - -(** Rewrite type of an evar ([ H1 : t1, ... Hn : tn |- concl ]) - to a product : forall H1 : t1, ..., forall Hn : tn, concl. - Changes evars and hypothesis references to variable references. -*) -let etype_of_evar evm evs hyps concl = - let open Context.Named.Declaration in - let rec aux acc n = function - decl :: tl -> - let t', s, trans = subst_evar_constr evm evs n EConstr.mkVar (NamedDecl.get_type decl) in - let t'' = subst_vars acc 0 t' in - let rest, s', trans' = aux (NamedDecl.get_id decl :: acc) (succ n) tl in - let s' = Int.Set.union s s' in - let trans' = Id.Set.union trans trans' in - (match decl with - | LocalDef (id,c,_) -> - let c', s'', trans'' = subst_evar_constr evm evs n EConstr.mkVar c in - let c' = subst_vars acc 0 c' in - mkNamedProd_or_LetIn (LocalDef (id, c', t'')) rest, - Int.Set.union s'' s', - Id.Set.union trans'' trans' - | LocalAssum (id,_) -> - mkNamedProd_or_LetIn (LocalAssum (id, t'')) rest, s', trans') - | [] -> - let t', s, trans = subst_evar_constr evm evs n EConstr.mkVar concl in - subst_vars acc 0 t', s, trans - in aux [] 0 (List.rev hyps) - -let trunc_named_context n ctx = - let len = List.length ctx in - List.firstn (len - n) ctx - -let rec chop_product n t = - let pop t = Vars.lift (-1) t in - if Int.equal n 0 then Some t - else - match Constr.kind t with - | Prod (_, _, b) -> if noccurn 1 b then chop_product (pred n) (pop b) else None - | _ -> None - -let evar_dependencies evm oev = - let one_step deps = - Evar.Set.fold (fun ev s -> - let evi = Evd.find evm ev in - let deps' = evars_of_filtered_evar_info evm evi in - if Evar.Set.mem oev deps' then - invalid_arg ("Ill-formed evar map: cycle detected for evar " ^ Pp.string_of_ppcmds @@ Evar.print oev) - else Evar.Set.union deps' s) - deps deps - in - let rec aux deps = - let deps' = one_step deps in - if Evar.Set.equal deps deps' then deps - else aux deps' - in aux (Evar.Set.singleton oev) - -let move_after (id, ev, deps as obl) l = - let rec aux restdeps = function - | (id', _, _) as obl' :: tl -> - let restdeps' = Evar.Set.remove id' restdeps in - if Evar.Set.is_empty restdeps' then - obl' :: obl :: tl - else obl' :: aux restdeps' tl - | [] -> [obl] - in aux (Evar.Set.remove id deps) l - -let sort_dependencies evl = - let rec aux l found list = - match l with - | (id, ev, deps) as obl :: tl -> - let found' = Evar.Set.union found (Evar.Set.singleton id) in - if Evar.Set.subset deps found' then - aux tl found' (obl :: list) - else aux (move_after obl tl) found list - | [] -> List.rev list - in aux evl Evar.Set.empty [] - -open Environ - -let eterm_obligations env name evm fs ?status t ty = - (* 'Serialize' the evars *) - let nc = Environ.named_context env in - let nc_len = Context.Named.length nc in - let evm = Evarutil.nf_evar_map_undefined evm in - let evl = Evarutil.non_instantiated evm in - let evl = Evar.Map.bindings evl in - let evl = List.map (fun (id, ev) -> (id, ev, evar_dependencies evm id)) evl in - let sevl = sort_dependencies evl in - let evl = List.map (fun (id, ev, _) -> id, ev) sevl in - let evn = - let i = ref (-1) in - List.rev_map (fun (id, ev) -> incr i; - (id, (!i, Id.of_string - (Id.to_string name ^ "_obligation_" ^ string_of_int (succ !i))), - ev)) evl - in - let evts = - (* Remove existential variables in types and build the corresponding products *) - List.fold_right - (fun (id, (n, nstr), ev) l -> - let hyps = Evd.evar_filtered_context ev in - let hyps = trunc_named_context nc_len hyps in - let evtyp, deps, transp = etype_of_evar evm l hyps ev.evar_concl in - let evtyp, hyps, chop = - match chop_product fs evtyp with - | Some t -> t, trunc_named_context fs hyps, fs - | None -> evtyp, hyps, 0 - in - let loc, k = evar_source id evm in - let status = match k with - | Evar_kinds.QuestionMark { Evar_kinds.qm_obligation=o } -> o - | _ -> match status with - | Some o -> o - | None -> Evar_kinds.Define (not (Program.get_proofs_transparency ())) - in - let force_status, status, chop = match status with - | Evar_kinds.Define true as stat -> - if not (Int.equal chop fs) then true, Evar_kinds.Define false, None - else false, stat, Some chop - | s -> false, s, None - in - let info = { ev_name = (n, nstr); - ev_hyps = hyps; ev_status = force_status, status; ev_chop = chop; - ev_src = loc, k; ev_typ = evtyp ; ev_deps = deps; ev_tac = None } - in (id, info) :: l) - evn [] - in - let t', _, transparent = (* Substitute evar refs in the term by variables *) - subst_evar_constr evm evts 0 EConstr.mkVar t - in - let ty, _, _ = subst_evar_constr evm evts 0 EConstr.mkVar ty in - let evars = - List.map (fun (ev, info) -> - let { ev_name = (_, name); ev_status = force_status, status; - ev_src = src; ev_typ = typ; ev_deps = deps; ev_tac = tac } = info - in - let force_status, status = match status with - | Evar_kinds.Define true when Id.Set.mem name transparent -> - true, Evar_kinds.Define false - | _ -> force_status, status - in name, typ, src, (force_status, status), deps, tac) evts - in - let evnames = List.map (fun (ev, info) -> ev, snd info.ev_name) evts in - let evmap f c = pi1 (subst_evar_constr evm evts 0 f c) in - Array.of_list (List.rev evars), (evnames, evmap), t', ty +open DeclareObl.Obligation +open DeclareObl.ProgramDecl let pperror cmd = CErrors.user_err ~hdr:"Program" cmd let error s = pperror (str s) @@ -272,84 +34,35 @@ let explain_no_obligations = function Some ident -> str "No obligations for program " ++ Id.print ident | None -> str "No obligations remaining" -type obligation_info = - (Names.Id.t * types * Evar_kinds.t Loc.located * - (bool * Evar_kinds.obligation_definition_status) - * Int.Set.t * unit Proofview.tactic option) array - let assumption_message = Declare.assumption_message let default_tactic = ref (Proofview.tclUNIT ()) -let evar_of_obligation o = make_evar (Global.named_context_val ()) (EConstr.of_constr o.obl_type) +let evar_of_obligation o = Evd.make_evar (Global.named_context_val ()) (EConstr.of_constr o.obl_type) let subst_deps expand obls deps t = - let osubst = obl_substitution expand obls deps in + let osubst = DeclareObl.obl_substitution expand obls deps in (Vars.replace_vars (List.map (fun (n, (_, b)) -> n, b) osubst) t) let subst_deps_obl obls obl = let t' = subst_deps true obls obl.obl_deps obl.obl_type in - { obl with obl_type = t' } + Obligation.set_type ~typ:t' obl open Evd -let unfold_entry cst = Hints.HintsUnfoldEntry [EvalConstRef cst] - -let add_local_hint prg cst = - Hints.add_hints ~locality:Goptions.OptLocal [Id.to_string prg.prg_name] (unfold_entry cst) - -let init_prog_info ?(opaque = false) ?hook n udecl b t ctx deps fixkind - notations obls impls ~scope ~poly ~kind reduce = - let obls', b = - match b with - | None -> - assert(Int.equal (Array.length obls) 0); - let n = Nameops.add_suffix n "_obligation" in - [| { obl_name = n; obl_body = None; - obl_location = Loc.tag Evar_kinds.InternalHole; obl_type = t; - obl_status = false, Evar_kinds.Expand; obl_deps = Int.Set.empty; - obl_tac = None } |], - mkVar n - | Some b -> - Array.mapi - (fun i (n, t, l, o, d, tac) -> - { obl_name = n ; obl_body = None; - obl_location = l; obl_type = t; obl_status = o; - obl_deps = d; obl_tac = tac }) - obls, b - in - let ctx = UState.make_flexible_nonalgebraic ctx in - { prg_name = n - ; prg_body = b - ; prg_type = reduce t - ; prg_ctx = ctx - ; prg_univdecl = udecl - ; prg_obligations = (obls', Array.length obls') - ; prg_deps = deps - ; prg_fixkind = fixkind - ; prg_notations = notations - ; prg_implicits = impls - ; prg_poly = poly - ; prg_scope = scope - ; prg_kind = kind - ; prg_reduce = reduce - ; prg_hook = hook - ; prg_opaque = opaque - } - let map_cardinal m = let i = ref 0 in ProgMap.iter (fun _ v -> - if snd (CEphemeron.get v).prg_obligations > 0 then incr i) m; + if (CEphemeron.get v).prg_obligations.remaining > 0 then incr i) m; !i -exception Found of program_info CEphemeron.key +exception Found of ProgramDecl.t CEphemeron.key let map_first m = try ProgMap.iter (fun _ v -> - if snd (CEphemeron.get v).prg_obligations > 0 then - raise (Found v)) m; + if (CEphemeron.get v).prg_obligations.remaining > 0 then + raise (Found v)) m; assert(false) with Found x -> x @@ -416,16 +129,14 @@ let warn_solve_errored = CWarnings.create ~name:"solve_obligation_error" ~catego Pp.seq [str "Solve Obligations tactic returned error: "; err; fnl (); str "This will become an error in the future"]) -let solve_by_tac ?loc name evi t poly ctx = - (* spiwack: the status is dropped. *) +let solve_by_tac ?loc name evi t poly uctx = try - let (entry,_,ctx') = - Pfedit.build_constant_by_tactic - ~name ~poly ctx evi.evar_hyps evi.evar_concl t in + (* the status is dropped. *) let env = Global.env () in - let body, ctx' = Declare.inline_private_constants ~univs:ctx' env entry in - Inductiveops.control_only_guard env (Evd.from_ctx ctx') (EConstr.of_constr body); - Some (body, entry.Declare.proof_entry_type, ctx') + let body, types, _, uctx = + Pfedit.build_by_tactic env ~uctx ~poly ~typ:evi.evar_concl t in + Inductiveops.control_only_guard env (Evd.from_ctx uctx) (EConstr.of_constr body); + Some (body, types, uctx) with | Refiner.FailError (_, s) as exn -> let _ = Exninfo.capture exn in @@ -438,43 +149,9 @@ let solve_by_tac ?loc name evi t poly ctx = warn_solve_errored ?loc err; None -let obligation_hook prg obl num auto { DeclareDef.Hook.S.uctx = ctx'; dref; _ } = - let obls, rem = prg.prg_obligations in - let cst = match dref with GlobRef.ConstRef cst -> cst | _ -> assert false in - let transparent = evaluable_constant cst (Global.env ()) in - let () = match obl.obl_status with - (true, Evar_kinds.Expand) - | (true, Evar_kinds.Define true) -> - if not transparent then err_not_transp () - | _ -> () - in - let inst, ctx' = - if not prg.prg_poly (* Not polymorphic *) then - (* The universe context was declared globally, we continue - from the new global environment. *) - let ctx = UState.make ~lbound:(Global.universes_lbound ()) (Global.universes ()) in - let ctx' = UState.merge_subst ctx (UState.subst ctx') in - Univ.Instance.empty, ctx' - else - (* We get the right order somehow, but surely it could be enforced in a clearer way. *) - let uctx = UState.context ctx' in - Univ.UContext.instance uctx, ctx' - in - let obl = { obl with obl_body = Some (DefinedObl (cst, inst)) } in - let () = if transparent then add_local_hint prg cst in - let obls = Array.copy obls in - let () = obls.(num) <- obl in - let prg = { prg with prg_ctx = ctx' } in - let () = ignore (update_obls prg obls (pred rem)) in - if pred rem > 0 then begin - let deps = dependencies obls num in - if not (Int.Set.is_empty deps) then - ignore (auto (Some prg.prg_name) deps None) - end - let rec solve_obligation prg num tac = let user_num = succ num in - let obls, rem = prg.prg_obligations in + let { obls; remaining=rem } = prg.prg_obligations in let obl = obls.(num) in let remaining = deps_remaining obls obl.obl_deps in let () = @@ -491,7 +168,7 @@ let rec solve_obligation prg num tac = let evd = Evd.update_sigma_env evd (Global.env ()) in let auto n oblset tac = auto_solve_obligations n ~oblset tac in let proof_ending = Lemmas.Proof_ending.End_obligation (DeclareObl.{name = prg.prg_name; num; auto}) in - let hook = DeclareDef.Hook.make (obligation_hook prg obl num auto) in + let hook = DeclareDef.Hook.make (DeclareObl.obligation_hook prg obl num auto) in let info = Lemmas.Info.make ~hook ~proof_ending ~scope ~kind () in let poly = prg.prg_poly in let lemma = Lemmas.start_lemma ~name:obl.obl_name ~poly ~info evd (EConstr.of_constr obl.obl_type) in @@ -502,7 +179,7 @@ let rec solve_obligation prg num tac = and obligation (user_num, name, typ) tac = let num = pred user_num in let prg = get_prog_err name in - let obls, rem = prg.prg_obligations in + let { obls; remaining } = prg.prg_obligations in if num >= 0 && num < Array.length obls then let obl = obls.(num) in match obl.obl_body with @@ -532,8 +209,9 @@ and solve_obligation_by_tac prg obls i tac = prg.prg_poly (Evd.evar_universe_context evd) with | None -> None | Some (t, ty, ctx) -> + let prg = ProgramDecl.set_uctx ~uctx:ctx prg in + (* Why is uctx not used above? *) let uctx = UState.univ_entry ~poly:prg.prg_poly ctx in - let prg = {prg with prg_ctx = ctx} in let def, obl' = declare_obligation prg obl t ty uctx in obls.(i) <- obl'; if def && not prg.prg_poly then ( @@ -541,13 +219,13 @@ and solve_obligation_by_tac prg obls i tac = let evd = Evd.from_env (Global.env ()) in let evd = Evd.merge_universe_subst evd (Evd.universe_subst (Evd.from_ctx ctx)) in let ctx' = Evd.evar_universe_context evd in - Some {prg with prg_ctx = ctx'}) + Some (ProgramDecl.set_uctx ~uctx:ctx' prg)) else Some prg else None and solve_prg_obligations prg ?oblset tac = - let obls, rem = prg.prg_obligations in - let rem = ref rem in + let { obls; remaining } = prg.prg_obligations in + let rem = ref remaining in let obls' = Array.copy obls in let set = ref Int.Set.empty in let p = match oblset with @@ -555,20 +233,20 @@ and solve_prg_obligations prg ?oblset tac = | Some s -> set := s; (fun i -> Int.Set.mem i !set) in - let prgref = ref prg in - let () = - Array.iteri (fun i x -> + let prg = + Array.fold_left_i (fun i prg x -> if p i then - match solve_obligation_by_tac !prgref obls' i tac with - | None -> () - | Some prg' -> - prgref := prg'; - let deps = dependencies obls i in - (set := Int.Set.union !set deps; - decr rem)) - obls' + match solve_obligation_by_tac prg obls' i tac with + | None -> prg + | Some prg -> + let deps = dependencies obls i in + set := Int.Set.union !set deps; + decr rem; + prg + else prg) + prg obls' in - update_obls !prgref obls' !rem + update_obls prg obls' !rem and solve_obligations n tac = let prg = get_prog_err n in @@ -579,10 +257,10 @@ and solve_all_obligations tac = and try_solve_obligation n prg tac = let prg = get_prog prg in - let obls, rem = prg.prg_obligations in + let {obls; remaining } = prg.prg_obligations in let obls' = Array.copy obls in match solve_obligation_by_tac prg obls' n tac with - | Some prg' -> ignore(update_obls prg' obls' (pred rem)) + | Some prg' -> ignore(update_obls prg' obls' (pred remaining)) | None -> () and try_solve_obligations n tac = @@ -595,9 +273,9 @@ and auto_solve_obligations n ?oblset tac : progress = open Pp let show_obligations_of_prg ?(msg=true) prg = let n = prg.prg_name in - let obls, rem = prg.prg_obligations in + let {obls; remaining} = prg.prg_obligations in let showed = ref 5 in - if msg then Feedback.msg_info (int rem ++ str " obligation(s) remaining: "); + if msg then Feedback.msg_info (int remaining ++ str " obligation(s) remaining: "); Array.iteri (fun i x -> match x.obl_body with | None -> @@ -630,12 +308,12 @@ let show_term n = Printer.pr_constr_env env sigma prg.prg_type ++ spc () ++ str ":=" ++ fnl () ++ Printer.pr_constr_env env sigma prg.prg_body) -let add_definition ~name ?term t ctx ?(univdecl=UState.default_univ_decl) - ?(implicits=[]) ~poly ?(scope=DeclareDef.Global Declare.ImportDefaultBehavior) ?(kind=Decls.Definition) ?tactic +let add_definition ~name ?term t ~uctx ?(udecl=UState.default_univ_decl) + ?(impargs=[]) ~poly ?(scope=DeclareDef.Global Declare.ImportDefaultBehavior) ?(kind=Decls.Definition) ?tactic ?(reduce=reduce) ?hook ?(opaque = false) obls = let info = Id.print name ++ str " has type-checked" in - let prg = init_prog_info ~opaque name univdecl term t ctx [] None [] obls implicits ~poly ~scope ~kind reduce ?hook in - let obls,_ = prg.prg_obligations in + let prg = ProgramDecl.make ~opaque name ~udecl term t ~uctx [] None [] obls ~impargs ~poly ~scope ~kind reduce ?hook in + let {obls;_} = prg.prg_obligations in if Int.equal (Array.length obls) 0 then ( Flags.if_verbose Feedback.msg_info (info ++ str "."); let cst = DeclareObl.declare_definition prg in @@ -649,15 +327,15 @@ let add_definition ~name ?term t ctx ?(univdecl=UState.default_univ_decl) | Remain rem -> Flags.if_verbose (fun () -> show_obligations ~msg:false (Some name)) (); res | _ -> res) -let add_mutual_definitions l ctx ?(univdecl=UState.default_univ_decl) ?tactic +let add_mutual_definitions l ~uctx ?(udecl=UState.default_univ_decl) ?tactic ~poly ?(scope=DeclareDef.Global Declare.ImportDefaultBehavior) ?(kind=Decls.Definition) ?(reduce=reduce) ?hook ?(opaque = false) notations fixkind = - let deps = List.map (fun (n, b, t, imps, obls) -> n) l in + let deps = List.map (fun ({ DeclareDef.Recthm.name; _ }, _, _) -> name) l in List.iter - (fun (n, b, t, imps, obls) -> - let prg = init_prog_info ~opaque n univdecl (Some b) t ctx deps (Some fixkind) - notations obls imps ~poly ~scope ~kind reduce ?hook - in progmap_add n (CEphemeron.create prg)) l; + (fun ({ DeclareDef.Recthm.name; typ; impargs; _ }, b, obls) -> + let prg = ProgramDecl.make ~opaque name ~udecl (Some b) typ ~uctx deps (Some fixkind) + notations obls ~impargs ~poly ~scope ~kind reduce ?hook + in progmap_add name (CEphemeron.create prg)) l; let _defined = List.fold_left (fun finished x -> if finished then finished @@ -672,7 +350,7 @@ let add_mutual_definitions l ctx ?(univdecl=UState.default_univ_decl) ?tactic in () let admit_prog prg = - let obls, rem = prg.prg_obligations in + let {obls; remaining} = prg.prg_obligations in let obls = Array.copy obls in Array.iteri (fun i x -> @@ -684,10 +362,10 @@ let admit_prog prg = (Declare.ParameterEntry (None,(x.obl_type,ctx),None)) ~kind:Decls.(IsAssumption Conjectural) in assumption_message x.obl_name; - obls.(i) <- { x with obl_body = Some (DefinedObl (kn, Univ.Instance.empty)) } + obls.(i) <- Obligation.set_body ~body:(DefinedObl (kn, Univ.Instance.empty)) x | Some _ -> ()) obls; - ignore(update_obls prg obls 0) + ignore(DeclareObl.update_obls prg obls 0) let rec admit_all_obligations () = let prg = try Some (get_any_prog ()) with NoObligations _ -> None in @@ -709,7 +387,7 @@ let next_obligation n tac = | None -> get_any_prog_err () | Some _ -> get_prog_err n in - let obls, rem = prg.prg_obligations in + let {obls; remaining} = prg.prg_obligations in let is_open _ x = Option.is_empty x.obl_body && List.is_empty (deps_remaining obls x.obl_deps) in let i = match Array.findi is_open obls with | Some i -> i diff --git a/vernac/obligations.mli b/vernac/obligations.mli index 6a2eb1472e..f42d199e18 100644 --- a/vernac/obligations.mli +++ b/vernac/obligations.mli @@ -8,52 +8,74 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -open Environ open Constr -open Evd -open Names - -val check_evars : env -> evar_map -> unit - -val evar_dependencies : evar_map -> Evar.t -> Evar.Set.t -val sort_dependencies : (Evar.t * evar_info * Evar.Set.t) list -> (Evar.t * evar_info * Evar.Set.t) list - -(* ident, type, location, (opaque or transparent, expand or define), dependencies, tactic to solve it *) -type obligation_info = - (Id.t * types * Evar_kinds.t Loc.located * - (bool * Evar_kinds.obligation_definition_status) * Int.Set.t * unit Proofview.tactic option) array - -(* env, id, evars, number of function prototypes to try to clear from - evars contexts, object and type *) -val eterm_obligations - : env - -> Id.t - -> evar_map - -> int - -> ?status:Evar_kinds.obligation_definition_status - -> EConstr.constr - -> EConstr.types - -> obligation_info * - - (* Existential key, obl. name, type as product, location of the - original evar, associated tactic, status and dependencies as - indexes into the array *) - ((Evar.t * Id.t) list * ((Id.t -> EConstr.constr) -> EConstr.constr -> constr)) * - - (* Translations from existential identifiers to obligation - identifiers and for terms with existentials to closed terms, - given a translation from obligation identifiers to constrs, - new term, new type *) - constr * types + +(** Coq's Program mode support. This mode extends declarations of + constants and fixpoints with [Program Definition] and [Program + Fixpoint] to support incremental construction of terms using + delayed proofs, called "obligations" + + The mode also provides facilities for managing and auto-solving + sets of obligations. + + The basic code flow of programs/obligations is as follows: + + - [add_definition] / [add_mutual_definitions] are called from the + respective [Program] vernacular command interpretation; at this + point the only extra work we do is to prepare the new definition + [d] using [RetrieveObl], which consists in turning unsolved evars + into obligations. [d] is not sent to the kernel yet, as it is not + complete and cannot be typchecked, but saved in a special + data-structure. Auto-solving of obligations is tried at this stage + (see below) + + - [next_obligation] will retrieve the next obligation + ([RetrieveObl] sorts them by topological order) and will try to + solve it. When all obligations are solved, the original constant + [d] is grounded and sent to the kernel for addition to the global + environment. Auto-solving of obligations is also triggered on + obligation completion. + +{2} Solving of obligations: Solved obligations are stored as regular + global declarations in the global environment, usually with name + [constant_obligation_number] where [constant] is the original + [constant] and [number] is the corresponding (internal) number. + + Solving an obligation can trigger a bit of a complex cascaded + callback path; closing an obligation can indeed allow all other + obligations to be closed, which in turn may trigged the declaration + of the original constant. Care must be taken, as this can modify + [Global.env] in arbitrarily ways. Current code takes some care to + refresh the [env] in the proper boundaries, but the invariants + remain delicate. + +{2} Saving of obligations: as open obligations use the regular proof + mode, a `Qed` will call `Lemmas.save_lemma` first. For this reason + obligations code is split in two: this file, [Obligations], taking + care of the top-level vernac commands, and [DeclareObl], which is + called by `Lemmas` to close an obligation proof and eventually to + declare the top-level [Program]ed constant. + + There is little obligations-specific code in [DeclareObl], so + eventually that file should be integrated in the regular [Declare] + path, as it gains better support for "dependent_proofs". + + *) val default_tactic : unit Proofview.tactic ref -val add_definition - : name:Names.Id.t - -> ?term:constr -> types - -> UState.t - -> ?univdecl:UState.universe_decl (* Universe binders and constraints *) - -> ?implicits:Impargs.manual_implicits +(** Start a [Program Definition c] proof. [uctx] [udecl] [impargs] + [kind] [scope] [poly] etc... come from the interpretation of the + vernacular; `obligation_info` was generated by [RetrieveObl] It + will return whether all the obligations were solved; if so, it will + also register [c] with the kernel. *) +val add_definition : + name:Names.Id.t + -> ?term:constr + -> types + -> uctx:UState.t + -> ?udecl:UState.universe_decl (** Universe binders and constraints *) + -> ?impargs:Impargs.manual_implicits -> poly:bool -> ?scope:DeclareDef.locality -> ?kind:Decls.definition_object_kind @@ -61,51 +83,56 @@ val add_definition -> ?reduce:(constr -> constr) -> ?hook:DeclareDef.Hook.t -> ?opaque:bool - -> obligation_info + -> RetrieveObl.obligation_info -> DeclareObl.progress -val add_mutual_definitions - : (Names.Id.t * constr * types * Impargs.manual_implicits * obligation_info) list - -> UState.t - -> ?univdecl:UState.universe_decl - (** Universe binders and constraints *) +(* XXX: unify with MutualEntry *) + +(** Start a [Program Fixpoint] declaration, similar to the above, + except it takes a list now. *) +val add_mutual_definitions : + (DeclareDef.Recthm.t * Constr.t * RetrieveObl.obligation_info) list + -> uctx:UState.t + -> ?udecl:UState.universe_decl (** Universe binders and constraints *) -> ?tactic:unit Proofview.tactic -> poly:bool -> ?scope:DeclareDef.locality -> ?kind:Decls.definition_object_kind -> ?reduce:(constr -> constr) - -> ?hook:DeclareDef.Hook.t -> ?opaque:bool + -> ?hook:DeclareDef.Hook.t + -> ?opaque:bool -> Vernacexpr.decl_notation list - -> DeclareObl.fixpoint_kind -> unit + -> DeclareObl.fixpoint_kind + -> unit -val obligation - : int * Names.Id.t option * Constrexpr.constr_expr option +(** Implementation of the [Obligation] command *) +val obligation : + int * Names.Id.t option * Constrexpr.constr_expr option -> Genarg.glob_generic_argument option -> Lemmas.t -val next_obligation - : Names.Id.t option - -> Genarg.glob_generic_argument option - -> Lemmas.t +(** Implementation of the [Next Obligation] command *) +val next_obligation : + Names.Id.t option -> Genarg.glob_generic_argument option -> Lemmas.t -val solve_obligations : Names.Id.t option -> unit Proofview.tactic option - -> DeclareObl.progress -(* Number of remaining obligations to be solved for this program *) +(** Implementation of the [Solve Obligation] command *) +val solve_obligations : + Names.Id.t option -> unit Proofview.tactic option -> DeclareObl.progress val solve_all_obligations : unit Proofview.tactic option -> unit -val try_solve_obligation : int -> Names.Id.t option -> unit Proofview.tactic option -> unit +(** Number of remaining obligations to be solved for this program *) +val try_solve_obligation : + int -> Names.Id.t option -> unit Proofview.tactic option -> unit -val try_solve_obligations : Names.Id.t option -> unit Proofview.tactic option -> unit +val try_solve_obligations : + Names.Id.t option -> unit Proofview.tactic option -> unit val show_obligations : ?msg:bool -> Names.Id.t option -> unit - val show_term : Names.Id.t option -> Pp.t - val admit_obligations : Names.Id.t option -> unit exception NoObligations of Names.Id.t option val explain_no_obligations : Names.Id.t option -> Pp.t - val check_program_libraries : unit -> unit diff --git a/vernac/ppvernac.ml b/vernac/ppvernac.ml index 5808c55cfc..054b60853f 100644 --- a/vernac/ppvernac.ml +++ b/vernac/ppvernac.ml @@ -142,7 +142,7 @@ open Pputils | SearchOutside [] -> mt() | SearchOutside l -> spc() ++ keyword "outside" ++ spc() ++ prlist_with_sep sep pr_module l - let pr_search_about (b,c) = + let pr_search (b,c) = (if b then str "-" else mt()) ++ match c with | SearchSubPattern p -> @@ -158,10 +158,8 @@ open Pputils | SearchHead c -> keyword "SearchHead" ++ spc() ++ pr_p c ++ pr_in_out_modules b | SearchPattern c -> keyword "SearchPattern" ++ spc() ++ pr_p c ++ pr_in_out_modules b | SearchRewrite c -> keyword "SearchRewrite" ++ spc() ++ pr_p c ++ pr_in_out_modules b - | SearchAbout sl -> - keyword "SearchAbout" ++ spc() ++ prlist_with_sep spc pr_search_about sl ++ pr_in_out_modules b | Search sl -> - keyword "Search" ++ spc() ++ prlist_with_sep spc pr_search_about sl ++ pr_in_out_modules b + keyword "Search" ++ spc() ++ prlist_with_sep spc pr_search sl ++ pr_in_out_modules b let pr_option_ref_value = function | QualidRefValue id -> pr_qualid id @@ -804,7 +802,7 @@ let string_of_definition_object_kind = let open Decls in function 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) discharge kind ++ pr_non_empty_arg pr_assumption_inline t ++ spc() ++ assumptions)) - | VernacInductive (cum, p,f,l) -> + | VernacInductive (f,l) -> let pr_constructor (coe,(id,c)) = hov 2 (pr_lident id ++ str" " ++ (if coe then str":>" else str":") ++ @@ -830,24 +828,14 @@ let string_of_definition_object_kind = let open Decls in function str" :=") ++ pr_constructor_list lc ++ prlist (pr_decl_notation @@ pr_constr env sigma) ntn in - let key = - let kind = - match f with Record -> "Record" | Structure -> "Structure" - | Inductive_kw -> "Inductive" | CoInductive -> "CoInductive" - | Class _ -> "Class" | Variant -> "Variant" - in - if p then - let cm = - match cum with - | Some VernacCumulative -> "Cumulative" - | Some VernacNonCumulative -> "NonCumulative" - | None -> "" - in - cm ^ " " ^ kind - else kind + let kind = + match f with + | Record -> "Record" | Structure -> "Structure" + | Inductive_kw -> "Inductive" | CoInductive -> "CoInductive" + | Class _ -> "Class" | Variant -> "Variant" in return ( - hov 1 (pr_oneind key (List.hd l)) ++ + hov 1 (pr_oneind kind (List.hd l)) ++ (prlist (fun ind -> fnl() ++ hov 1 (pr_oneind "with" ind)) (List.tl l)) ) diff --git a/vernac/pvernac.ml b/vernac/pvernac.ml index 08625b41a6..f4cb1adfe8 100644 --- a/vernac/pvernac.ml +++ b/vernac/pvernac.ml @@ -51,14 +51,13 @@ module Vernac_ = let noedit_mode = gec_vernac "noedit_command" let () = - let open Extend in let act_vernac v loc = Some v in let act_eoi _ loc = None in let rule = [ - Rule (Next (Stop, Atoken Tok.PEOI), act_eoi); - Rule (Next (Stop, Aentry vernac_control), act_vernac); + Pcoq.(Production.make (Rule.next Rule.stop (Symbol.token Tok.PEOI)) act_eoi); + Pcoq.(Production.make (Rule.next Rule.stop (Symbol.nterm vernac_control)) act_vernac); ] in - Pcoq.grammar_extend main_entry (None, [None, None, rule]) + Pcoq.(grammar_extend main_entry {pos=None; data=[None, None, rule]}) let select_tactic_entry spec = match spec with diff --git a/vernac/retrieveObl.ml b/vernac/retrieveObl.ml new file mode 100644 index 0000000000..c529972b8d --- /dev/null +++ b/vernac/retrieveObl.ml @@ -0,0 +1,296 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Names + +(** + - Get types of existentials ; + - Flatten dependency tree (prefix order) ; + - Replace existentials by de Bruijn indices in term, applied to the right arguments ; + - Apply term prefixed by quantification on "existentials". +*) + +let check_evars env evm = + Evar.Map.iter + (fun key evi -> + if Evd.is_obligation_evar evm key then () + else + let loc, k = Evd.evar_source key evm in + Pretype_errors.error_unsolvable_implicit ?loc env evm key None) + (Evd.undefined_map evm) + +type obligation_info = + ( Names.Id.t + * Constr.types + * Evar_kinds.t Loc.located + * (bool * Evar_kinds.obligation_definition_status) + * Int.Set.t + * unit Proofview.tactic option ) + array + +type oblinfo = + { ev_name : int * Id.t + ; ev_hyps : EConstr.named_context + ; ev_status : bool * Evar_kinds.obligation_definition_status + ; ev_chop : int option + ; ev_src : Evar_kinds.t Loc.located + ; ev_typ : Constr.types + ; ev_tac : unit Proofview.tactic option + ; ev_deps : Int.Set.t } + +(** Substitute evar references in t using de Bruijn indices, + where n binders were passed through. *) + +let succfix (depth, fixrels) = (succ depth, List.map succ fixrels) + +let subst_evar_constr evm evs n idf t = + let seen = ref Int.Set.empty in + let transparent = ref Id.Set.empty in + let evar_info id = CList.assoc_f Evar.equal id evs in + let rec substrec (depth, fixrels) c = + match EConstr.kind evm c with + | Constr.Evar (k, args) -> + let {ev_name = id, idstr; ev_hyps = hyps; ev_chop = chop} = + try evar_info k + with Not_found -> + CErrors.anomaly ~label:"eterm" + Pp.( + str "existential variable " + ++ int (Evar.repr k) + ++ str " not found.") + in + seen := Int.Set.add id !seen; + (* Evar arguments are created in inverse order, + and we must not apply to defined ones (i.e. LetIn's) + *) + let args = + let n = match chop with None -> 0 | Some c -> c in + let l, r = CList.chop n (List.rev (Array.to_list args)) in + List.rev r + in + let args = + let rec aux hyps args acc = + let open Context.Named.Declaration in + match (hyps, args) with + | LocalAssum _ :: tlh, c :: tla -> + aux tlh tla (substrec (depth, fixrels) c :: acc) + | LocalDef _ :: tlh, _ :: tla -> aux tlh tla acc + | [], [] -> acc + | _, _ -> acc + (*failwith "subst_evars: invalid argument"*) + in + aux hyps args [] + in + if + List.exists + (fun x -> + match EConstr.kind evm x with + | Constr.Rel n -> Int.List.mem n fixrels + | _ -> false) + args + then transparent := Id.Set.add idstr !transparent; + EConstr.mkApp (idf idstr, Array.of_list args) + | Constr.Fix _ -> + EConstr.map_with_binders evm succfix substrec (depth, 1 :: fixrels) c + | _ -> EConstr.map_with_binders evm succfix substrec (depth, fixrels) c + in + let t' = substrec (0, []) t in + (EConstr.to_constr evm t', !seen, !transparent) + +(** Substitute variable references in t using de Bruijn indices, + where n binders were passed through. *) +let subst_vars acc n t = + let var_index id = Util.List.index Id.equal id acc in + let rec substrec depth c = + match Constr.kind c with + | Constr.Var v -> ( + try Constr.mkRel (depth + var_index v) with Not_found -> c ) + | _ -> Constr.map_with_binders succ substrec depth c + in + substrec 0 t + +(** Rewrite type of an evar ([ H1 : t1, ... Hn : tn |- concl ]) + to a product : forall H1 : t1, ..., forall Hn : tn, concl. + Changes evars and hypothesis references to variable references. +*) +let etype_of_evar evm evs hyps concl = + let open Context.Named.Declaration in + let rec aux acc n = function + | decl :: tl -> ( + let t', s, trans = + subst_evar_constr evm evs n EConstr.mkVar + (Context.Named.Declaration.get_type decl) + in + let t'' = subst_vars acc 0 t' in + let rest, s', trans' = + aux (Context.Named.Declaration.get_id decl :: acc) (succ n) tl + in + let s' = Int.Set.union s s' in + let trans' = Id.Set.union trans trans' in + match decl with + | LocalDef (id, c, _) -> + let c', s'', trans'' = subst_evar_constr evm evs n EConstr.mkVar c in + let c' = subst_vars acc 0 c' in + ( Term.mkNamedProd_or_LetIn (LocalDef (id, c', t'')) rest + , Int.Set.union s'' s' + , Id.Set.union trans'' trans' ) + | LocalAssum (id, _) -> + (Term.mkNamedProd_or_LetIn (LocalAssum (id, t'')) rest, s', trans') ) + | [] -> + let t', s, trans = subst_evar_constr evm evs n EConstr.mkVar concl in + (subst_vars acc 0 t', s, trans) + in + aux [] 0 (List.rev hyps) + +let trunc_named_context n ctx = + let len = List.length ctx in + CList.firstn (len - n) ctx + +let rec chop_product n t = + let pop t = Vars.lift (-1) t in + if Int.equal n 0 then Some t + else + match Constr.kind t with + | Constr.Prod (_, _, b) -> + if Vars.noccurn 1 b then chop_product (pred n) (pop b) else None + | _ -> None + +let evar_dependencies evm oev = + let one_step deps = + Evar.Set.fold + (fun ev s -> + let evi = Evd.find evm ev in + let deps' = Evd.evars_of_filtered_evar_info evm evi in + if Evar.Set.mem oev deps' then + invalid_arg + ( "Ill-formed evar map: cycle detected for evar " + ^ Pp.string_of_ppcmds @@ Evar.print oev ) + else Evar.Set.union deps' s) + deps deps + in + let rec aux deps = + let deps' = one_step deps in + if Evar.Set.equal deps deps' then deps else aux deps' + in + aux (Evar.Set.singleton oev) + +let move_after ((id, ev, deps) as obl) l = + let rec aux restdeps = function + | ((id', _, _) as obl') :: tl -> + let restdeps' = Evar.Set.remove id' restdeps in + if Evar.Set.is_empty restdeps' then obl' :: obl :: tl + else obl' :: aux restdeps' tl + | [] -> [obl] + in + aux (Evar.Set.remove id deps) l + +let sort_dependencies evl = + let rec aux l found list = + match l with + | ((id, ev, deps) as obl) :: tl -> + let found' = Evar.Set.union found (Evar.Set.singleton id) in + if Evar.Set.subset deps found' then aux tl found' (obl :: list) + else aux (move_after obl tl) found list + | [] -> List.rev list + in + aux evl Evar.Set.empty [] + +let retrieve_obligations env name evm fs ?status t ty = + (* 'Serialize' the evars *) + let nc = Environ.named_context env in + let nc_len = Context.Named.length nc in + let evm = Evarutil.nf_evar_map_undefined evm in + let evl = Evarutil.non_instantiated evm in + let evl = Evar.Map.bindings evl in + let evl = List.map (fun (id, ev) -> (id, ev, evar_dependencies evm id)) evl in + let sevl = sort_dependencies evl in + let evl = List.map (fun (id, ev, _) -> (id, ev)) sevl in + let evn = + let i = ref (-1) in + List.rev_map + (fun (id, ev) -> + incr i; + ( id + , ( !i + , Id.of_string + (Id.to_string name ^ "_obligation_" ^ string_of_int (succ !i)) ) + , ev )) + evl + in + let evts = + (* Remove existential variables in types and build the corresponding products *) + List.fold_right + (fun (id, (n, nstr), ev) l -> + let hyps = Evd.evar_filtered_context ev in + let hyps = trunc_named_context nc_len hyps in + let evtyp, deps, transp = etype_of_evar evm l hyps ev.Evd.evar_concl in + let evtyp, hyps, chop = + match chop_product fs evtyp with + | Some t -> (t, trunc_named_context fs hyps, fs) + | None -> (evtyp, hyps, 0) + in + let loc, k = Evd.evar_source id evm in + let status = + match k with + | Evar_kinds.QuestionMark {Evar_kinds.qm_obligation = o} -> o + | _ -> ( + match status with + | Some o -> o + | None -> + Evar_kinds.Define (not (Program.get_proofs_transparency ())) ) + in + let force_status, status, chop = + match status with + | Evar_kinds.Define true as stat -> + if not (Int.equal chop fs) then (true, Evar_kinds.Define false, None) + else (false, stat, Some chop) + | s -> (false, s, None) + in + let info = + { ev_name = (n, nstr) + ; ev_hyps = hyps + ; ev_status = (force_status, status) + ; ev_chop = chop + ; ev_src = (loc, k) + ; ev_typ = evtyp + ; ev_deps = deps + ; ev_tac = None } + in + (id, info) :: l) + evn [] + in + let t', _, transparent = + (* Substitute evar refs in the term by variables *) + subst_evar_constr evm evts 0 EConstr.mkVar t + in + let ty, _, _ = subst_evar_constr evm evts 0 EConstr.mkVar ty in + let evars = + List.map + (fun (ev, info) -> + let { ev_name = _, name + ; ev_status = force_status, status + ; ev_src = src + ; ev_typ = typ + ; ev_deps = deps + ; ev_tac = tac } = + info + in + let force_status, status = + match status with + | Evar_kinds.Define true when Id.Set.mem name transparent -> + (true, Evar_kinds.Define false) + | _ -> (force_status, status) + in + (name, typ, src, (force_status, status), deps, tac)) + evts + in + let evnames = List.map (fun (ev, info) -> (ev, snd info.ev_name)) evts in + let evmap f c = Util.pi1 (subst_evar_constr evm evts 0 f c) in + (Array.of_list (List.rev evars), (evnames, evmap), t', ty) diff --git a/vernac/retrieveObl.mli b/vernac/retrieveObl.mli new file mode 100644 index 0000000000..c9c45bd889 --- /dev/null +++ b/vernac/retrieveObl.mli @@ -0,0 +1,46 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +val check_evars : Environ.env -> Evd.evar_map -> unit + +type obligation_info = + ( Names.Id.t + * Constr.types + * Evar_kinds.t Loc.located + * (bool * Evar_kinds.obligation_definition_status) + * Int.Set.t + * unit Proofview.tactic option ) + array +(** ident, type, location of the original evar, (opaque or + transparent, expand or define), dependencies as indexes into the + array, tactic to solve it *) + +val retrieve_obligations : + Environ.env + -> Names.Id.t + -> Evd.evar_map + -> int + -> ?status:Evar_kinds.obligation_definition_status + -> EConstr.t + -> EConstr.types + -> obligation_info + * ( (Evar.t * Names.Id.t) list + * ((Names.Id.t -> EConstr.t) -> EConstr.t -> Constr.t) ) + * Constr.t + * Constr.t +(** [retrieve_obligations env id sigma fs ?status body type] returns + [obls, (evnames, evmap), nbody, ntype] a list of obligations built + from evars in [body, type]. + + [fs] is the number of function prototypes to try to clear from + evars contexts. [evnames, evmap) is the list of names / + substitution functions used to program with holes. This is not used + in Coq, but in the equations plugin; [evnames] is actually + redundant with the information contained in [obls] *) diff --git a/vernac/search.ml b/vernac/search.ml index ceff8acc79..68a30b4231 100644 --- a/vernac/search.ml +++ b/vernac/search.ml @@ -23,8 +23,8 @@ module NamedDecl = Context.Named.Declaration type filter_function = GlobRef.t -> env -> constr -> bool type display_function = GlobRef.t -> env -> constr -> unit -(* This option restricts the output of [SearchPattern ...], -[SearchAbout ...], etc. to the names of the symbols matching the +(* This option restricts the output of [SearchPattern ...], etc. +to the names of the symbols matching the query, separated by a newline. This type of output is useful for editors (like emacs), to generate a list of completion candidates without having to parse through the types of all symbols. *) @@ -226,7 +226,7 @@ let module_filter (mods, outside) ref env typ = let name_of_reference ref = Id.to_string (Nametab.basename_of_global ref) -let search_about_filter query gr env typ = match query with +let search_filter query gr env typ = match query with | GlobSearchSubPattern pat -> Constr_matching.is_matching_appsubterm ~closed:false env (Evd.from_env env) pat (EConstr.of_constr typ) | GlobSearchString s -> @@ -283,14 +283,14 @@ let search_by_head ?pstate gopt pat mods pr_search = in generic_search ?pstate gopt iter -(** SearchAbout *) +(** Search *) -let search_about ?pstate gopt items mods pr_search = +let search ?pstate gopt items mods pr_search = let filter ref env typ = let eqb b1 b2 = if b1 then b2 else not b2 in module_filter mods ref env typ && List.for_all - (fun (b,i) -> eqb b (search_about_filter i ref env typ)) items && + (fun (b,i) -> eqb b (search_filter i ref env typ)) items && blacklist_filter ref env typ in let iter ref env typ = diff --git a/vernac/search.mli b/vernac/search.mli index 11dd0c6794..6dbbff3a8c 100644 --- a/vernac/search.mli +++ b/vernac/search.mli @@ -30,8 +30,7 @@ val blacklist_filter : filter_function val module_filter : DirPath.t list * bool -> filter_function (** Check whether a reference pertains or not to a set of modules *) -val search_about_filter : glob_search_about_item -> filter_function -(** Check whether a reference matches a SearchAbout query. *) +val search_filter : glob_search_about_item -> filter_function (** {6 Specialized search functions} @@ -45,7 +44,7 @@ val search_rewrite : ?pstate:Proof_global.t -> int option -> constr_pattern -> D -> display_function -> unit val search_pattern : ?pstate:Proof_global.t -> int option -> constr_pattern -> DirPath.t list * bool -> display_function -> unit -val search_about : ?pstate:Proof_global.t -> int option -> (bool * glob_search_about_item) list +val search : ?pstate:Proof_global.t -> int option -> (bool * glob_search_about_item) list -> DirPath.t list * bool -> display_function -> unit type search_constraint = diff --git a/vernac/vernac.mllib b/vernac/vernac.mllib index 6e398d87ca..5a2bdb43d4 100644 --- a/vernac/vernac.mllib +++ b/vernac/vernac.mllib @@ -14,6 +14,7 @@ Proof_using Egramcoq Metasyntax DeclareUniv +RetrieveObl DeclareDef DeclareObl Canonical diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index b5ecd62dad..4806c6bb9c 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -473,11 +473,14 @@ let program_inference_hook env sigma ev = let concl = evi.Evd.evar_concl in if not (Evarutil.is_ground_env sigma env && Evarutil.is_ground_term sigma concl) - then raise Exit; - let c, _, ctx = - Pfedit.build_by_tactic ~poly:false env (Evd.evar_universe_context sigma) concl tac - in Evd.set_universe_context sigma ctx, EConstr.of_constr c - with Logic_monad.TacticFailure e when noncritical e -> + then None + else + let c, _, _, ctx = + Pfedit.build_by_tactic ~poly:false env ~uctx:(Evd.evar_universe_context sigma) ~typ:concl tac + in + Some (Evd.set_universe_context sigma ctx, EConstr.of_constr c) + with + | Logic_monad.TacticFailure e when noncritical e -> user_err Pp.(str "The statement obligations could not be resolved \ automatically, write a statement definition first.") @@ -493,17 +496,12 @@ let start_lemma_com ~program_mode ~poly ~scope ~kind ?hook thms = let evd = Pretyping.solve_remaining_evars ?hook:inference_hook flags env evd in let ids = List.map Context.Rel.Declaration.get_name ctx in check_name_freshness scope id; - (* XXX: The nf_evar is critical !! *) - evd, (id.CAst.v, - (Evarutil.nf_evar evd (EConstr.it_mkProd_or_LetIn t' ctx), - (ids, imps @ imps')))) + evd, (id.CAst.v, (EConstr.it_mkProd_or_LetIn t' ctx, (ids, imps @ imps')))) evd thms in let recguard,thms,snl = RecLemmas.look_for_possibly_mutual_statements evd thms in let evd = Evd.minimize_universes evd in - (* XXX: This nf_evar is critical too!! We are normalizing twice if - you look at the previous lines... *) let thms = List.map (fun (name, (typ, (args, impargs))) -> - { Lemmas.Recthm.name; typ = EConstr.to_constr evd typ; args; impargs} ) thms in + { DeclareDef.Recthm.name; typ = EConstr.to_constr evd typ; args; impargs} ) thms in let () = let open UState in if not (udecl.univdecl_extensible_instance && udecl.univdecl_extensible_constraints) then @@ -529,8 +527,10 @@ let vernac_definition_hook ~canonical_instance ~local ~poly = let open Decls in Some (DeclareDef.Hook.(make (fun { S.dref } -> Canonical.declare_canonical_structure dref))) | _ -> None +let default_thm_id = Id.of_string "Unnamed_thm" + let fresh_name_for_anonymous_theorem () = - Namegen.next_global_ident_away Lemmas.default_thm_id Id.Set.empty + Namegen.next_global_ident_away default_thm_id Id.Set.empty let vernac_definition_name lid local = let lid = @@ -567,7 +567,9 @@ let vernac_definition ~atts (discharge, kind) (lid, pl) bl red_option c typ_opt let env = Global.env () in let sigma = Evd.from_env env in Some (snd (Hook.get f_interp_redexp env sigma r)) in - ComDefinition.do_definition ~program_mode ~name:name.v + let do_definition = + ComDefinition.(if program_mode then do_definition_program else do_definition) in + do_definition ~name:name.v ~poly:atts.polymorphic ~scope ~kind pl bl red_option c typ_opt ?hook (* NB: pstate argument to use combinators easily *) @@ -604,17 +606,39 @@ let vernac_assumption ~atts discharge kind l nl = let is_polymorphic_inductive_cumulativity = declare_bool_option_and_ref ~depr:false ~value:false - ~key:["Polymorphic"; "Inductive"; "Cumulativity"] - -let should_treat_as_cumulative cum poly = - match cum with - | Some VernacCumulative -> - if poly then true - else user_err Pp.(str "The Cumulative prefix can only be used in a polymorphic context.") - | Some VernacNonCumulative -> - if poly then false - else user_err Pp.(str "The NonCumulative prefix can only be used in a polymorphic context.") - | None -> poly && is_polymorphic_inductive_cumulativity () + ~key:["Polymorphic";"Inductive";"Cumulativity"] + +let polymorphic_cumulative = + let error_poly_context () = + user_err + Pp.(str "The cumulative and noncumulative attributes can only be used in a polymorphic context."); + in + let open Attributes in + let open Notations in + qualify_attribute "universes" + (bool_attribute ~name:"Polymorphism" ~on:"polymorphic" ~off:"monomorphic" + ++ bool_attribute ~name:"Cumulativity" ~on:"cumulative" ~off:"noncumulative") + >>= function + | Some poly, Some cum -> + (* Case of Polymorphic|Monomorphic Cumulative|NonCumulative Inductive + and #[ universes(polymorphic|monomorphic,cumulative|noncumulative) ] Inductive *) + if poly then return (true, cum) + else error_poly_context () + | Some poly, None -> + (* Case of Polymorphic|Monomorphic Inductive + and #[ universes(polymorphic|monomorphic) ] Inductive *) + if poly then return (true, is_polymorphic_inductive_cumulativity ()) + else return (false, false) + | None, Some cum -> + (* Case of Cumulative|NonCumulative Inductive *) + if is_universe_polymorphism () then return (true, cum) + else error_poly_context () + | None, None -> + (* Case of Inductive *) + if is_universe_polymorphism () then + return (true, is_polymorphic_inductive_cumulativity ()) + else + return (false, false) let get_uniform_inductive_parameters = Goptions.declare_bool_option_and_ref @@ -627,8 +651,7 @@ let should_treat_as_uniform () = then ComInductive.UniformParameters else ComInductive.NonUniformParameters -let vernac_record ~template udecl cum k poly finite records = - let cumulative = should_treat_as_cumulative cum poly in +let vernac_record ~template udecl ~cumulative k ~poly finite records = let map ((coe, id), binders, sort, nameopt, cfs) = let const = match nameopt with | None -> Nameops.add_prefix "Build_" id.v @@ -668,12 +691,21 @@ let finite_of_kind = let open Declarations in function | CoInductive -> CoFinite | Variant | Record | Structure | Class _ -> BiFinite -(** 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 ~atts cum lo kind indl = - let template, poly = Attributes.(parse Notations.(template ++ polymorphic) atts) in +let private_ind = + let open Attributes in + let open Notations in + attribute_of_list + [ "matching" + , single_key_parser ~name:"Private (matching) inductive type" ~key:"matching" () + ] + |> qualify_attribute "private" + >>= function + | Some () -> return true + | None -> return false + +let vernac_inductive ~atts kind indl = + let (template, (poly, cumulative)), private_ind = Attributes.( + parse Notations.(template ++ polymorphic_cumulative ++ private_ind) atts) in let open Pp in let udecl, indl = extract_inductive_udecl indl in if Dumpglob.dump () then @@ -710,7 +742,7 @@ let vernac_inductive ~atts cum lo kind indl = let coe' = if coe then Some true else None in let f = AssumExpr ((make ?loc:lid.loc @@ Name lid.v), ce), { rf_subclass = coe' ; rf_priority = None ; rf_notation = [] ; rf_canonical = true } in - vernac_record ~template udecl cum (Class true) poly finite [id, bl, c, None, [f]] + vernac_record ~template udecl ~cumulative (Class true) ~poly finite [id, bl, c, None, [f]] else if List.for_all is_record indl then (* Mutual record case *) let () = match kind with @@ -735,7 +767,7 @@ let vernac_inductive ~atts cum lo kind indl = in let kind = match kind with Class _ -> Class false | _ -> kind in let recordl = List.map unpack indl in - vernac_record ~template udecl cum kind poly finite recordl + vernac_record ~template udecl ~cumulative kind ~poly finite recordl else if List.for_all is_constructor indl then (* Mutual inductive case *) let () = match kind with @@ -758,9 +790,8 @@ let vernac_inductive ~atts cum lo kind indl = | RecordDecl _ -> assert false (* ruled out above *) in let indl = List.map unpack indl in - let cumulative = should_treat_as_cumulative cum poly in let uniform = should_treat_as_uniform () in - ComInductive.do_mutual_inductive ~template udecl indl ~cumulative ~poly ~private_ind:lo ~uniform finite + ComInductive.do_mutual_inductive ~template udecl indl ~cumulative ~poly ~private_ind ~uniform finite else user_err (str "Mixed record-inductive definitions are not allowed") @@ -956,7 +987,7 @@ let vernac_begin_section ~poly ({v=id} as lid) = to its current value ie noop. *) set_bool_option_value_gen ~locality:OptLocal ["Universe"; "Polymorphism"] poly -let vernac_end_section {CAst.loc} = +let vernac_end_section {CAst.loc; v} = Dumpglob.dump_reference ?loc (DirPath.to_string (Lib.current_dirpath true)) "<>" "sec"; Lib.close_section () @@ -966,6 +997,7 @@ let vernac_name_sec_hyp {v=id} set = Proof_using.name_set id set (* Dispatcher of the "End" command *) let vernac_end_segment ({v=id} as lid) = + DeclareObl.check_can_close lid.v; match Lib.find_opening_node id with | Lib.OpenedModule (false,export,_,_) -> vernac_end_module export lid | Lib.OpenedModule (true,_,_,_) -> vernac_end_modtype lid @@ -1464,40 +1496,29 @@ let vernac_set_opacity ~local (v,l) = let l = List.map glob_ref l in Redexpr.set_strategy local [v,l] -let get_option_locality export local = - if export then - if Option.is_empty local then OptExport - else user_err Pp.(str "Locality modifiers forbidden with Export") - else match local with - | Some true -> OptLocal - | Some false -> OptGlobal - | None -> OptDefault - -let vernac_set_option0 ~local export key opt = - let locality = get_option_locality export local in +let vernac_set_option0 ~locality key opt = match opt with | OptionUnset -> unset_option_value_gen ~locality key | OptionSetString s -> set_string_option_value_gen ~locality key s | OptionSetInt n -> set_int_option_value_gen ~locality key (Some n) | OptionSetTrue -> set_bool_option_value_gen ~locality key true -let vernac_set_append_option ~local export key s = - let locality = get_option_locality export local in +let vernac_set_append_option ~locality key s = set_string_option_append_value_gen ~locality key s -let vernac_set_option ~local export table v = match v with +let vernac_set_option ~locality table v = match v with | OptionSetString s -> (* We make a special case for warnings because appending is their natural semantics *) if CString.List.equal table ["Warnings"] then - vernac_set_append_option ~local export table s + vernac_set_append_option ~locality table s else let (last, prefix) = List.sep_last table in if String.equal last "Append" && not (List.is_empty prefix) then - vernac_set_append_option ~local export prefix s + vernac_set_append_option ~locality prefix s else - vernac_set_option0 ~local export table v -| _ -> vernac_set_option0 ~local export table v + vernac_set_option0 ~locality table v +| _ -> vernac_set_option0 ~locality table v let vernac_add_option key lv = let f = function @@ -1605,12 +1626,11 @@ let get_nth_goal ~pstate n = let gl = {Evd.it=List.nth goals (n-1) ; sigma = sigma; } in gl -exception NoHyp - (* Printing "About" information of a hypothesis of the current goal. We only print the type and a small statement to this comes from the goal. Precondition: there must be at least one current goal. *) let print_about_hyp_globs ~pstate ?loc ref_or_by_not udecl glopt = + let exception NoHyp in let open Context.Named.Declaration in try (* Fallback early to globals *) @@ -1757,10 +1777,6 @@ let () = optread = (fun () -> !search_output_name_only); optwrite = (:=) search_output_name_only } -let warn_deprecated_search_about = - CWarnings.create ~name:"deprecated-search-about" ~category:"deprecated" - (fun () -> strbrk "The SearchAbout command is deprecated. Please use Search instead.") - let vernac_search ~pstate ~atts s gopt r = let gopt = query_command_selector gopt in let r = interp_search_restriction r in @@ -1793,12 +1809,8 @@ let vernac_search ~pstate ~atts s gopt r = (Search.search_rewrite ?pstate gopt (get_pattern c) r |> Search.prioritize_search) pr_search | SearchHead c -> (Search.search_by_head ?pstate gopt (get_pattern c) r |> Search.prioritize_search) pr_search - | SearchAbout sl -> - warn_deprecated_search_about (); - (Search.search_about ?pstate gopt (List.map (on_snd (interp_search_about_item env Evd.(from_env env))) sl) r |> - Search.prioritize_search) pr_search | Search sl -> - (Search.search_about ?pstate gopt (List.map (on_snd (interp_search_about_item env Evd.(from_env env))) sl) r |> + (Search.search ?pstate gopt (List.map (on_snd (interp_search_about_item env Evd.(from_env env))) sl) r |> Search.prioritize_search) pr_search); Feedback.msg_notice (str "(use \"About\" for full details on implicit arguments)") @@ -2008,8 +2020,8 @@ let translate_vernac ~atts v = let open Vernacextend in match v with vernac_declare_module_type lid bl mtys mtyo) | VernacAssumption ((discharge,kind),nl,l) -> VtDefault(fun () -> with_def_attributes ~atts vernac_assumption discharge kind l nl) - | VernacInductive (cum, priv, finite, l) -> - VtDefault(fun () -> vernac_inductive ~atts cum priv finite l) + | VernacInductive (finite, l) -> + VtDefault(fun () -> vernac_inductive ~atts finite l) | VernacFixpoint (discharge, l) -> let opens = List.exists (fun { body_def } -> Option.is_empty body_def) l in if opens then @@ -2164,9 +2176,10 @@ let translate_vernac ~atts v = let open Vernacextend in match v with VtDefault(fun () -> with_locality ~atts vernac_set_opacity qidl) | VernacSetStrategy l -> VtDefault(fun () -> with_locality ~atts vernac_set_strategy l) - | VernacSetOption (export, key,v) -> + | VernacSetOption (export,key,v) -> + let atts = if export then ("export", VernacFlagEmpty) :: atts else atts in VtDefault(fun () -> - vernac_set_option ~local:(only_locality atts) export key v) + vernac_set_option ~locality:(parse option_locality atts) key v) | VernacRemoveOption (key,v) -> VtDefault(fun () -> unsupported_attributes atts; diff --git a/vernac/vernacexpr.ml b/vernac/vernacexpr.ml index efae1b8dfd..d6e7a3947a 100644 --- a/vernac/vernacexpr.ml +++ b/vernac/vernacexpr.ml @@ -69,7 +69,6 @@ type searchable = | SearchPattern of constr_pattern_expr | SearchRewrite of constr_pattern_expr | SearchHead of constr_pattern_expr - | SearchAbout of (bool * search_about_item) list | Search of (bool * search_about_item) list type locatable = @@ -250,10 +249,6 @@ type register_kind = type module_ast_inl = module_ast * Declaremods.inline type module_binder = bool option * lident list * module_ast_inl -(** [Some b] if locally enabled/disabled according to [b], [None] if - we should use the global flag. *) -type vernac_cumulative = VernacCumulative | VernacNonCumulative - (** {6 The type of vernacular expressions} *) type vernac_one_argument_status = { @@ -312,7 +307,7 @@ type nonrec vernac_expr = | VernacExactProof of constr_expr | VernacAssumption of (discharge * Decls.assumption_object_kind) * Declaremods.inline * (ident_decl list * constr_expr) with_coercion list - | VernacInductive of vernac_cumulative option * bool (* private *) * inductive_kind * (inductive_expr * decl_notation list) list + | VernacInductive of inductive_kind * (inductive_expr * decl_notation list) list | VernacFixpoint of discharge * fixpoint_expr list | VernacCoFixpoint of discharge * cofixpoint_expr list | VernacScheme of (lident option * scheme) list @@ -403,7 +398,7 @@ type nonrec vernac_expr = | VernacSetOpacity of (Conv_oracle.level * qualid or_by_notation list) | VernacSetStrategy of (Conv_oracle.level * qualid or_by_notation list) list - | VernacSetOption of export_flag * Goptions.option_name * option_setting + | VernacSetOption of bool (* Export modifier? *) * Goptions.option_name * option_setting | VernacAddOption of Goptions.option_name * option_ref_value list | VernacRemoveOption of Goptions.option_name * option_ref_value list | VernacMemOption of Goptions.option_name * option_ref_value list diff --git a/vernac/vernacextend.ml b/vernac/vernacextend.ml index 0e8202da9f..1920c276af 100644 --- a/vernac/vernacextend.ml +++ b/vernac/vernacextend.ml @@ -166,15 +166,15 @@ let rec untype_command : type r s. (r, s) ty_sig -> r -> plugin_args -> vernac_c | Some Refl -> untype_command ty (f v) args end -let rec untype_user_symbol : type s a b c. (a, b, c) Extend.ty_user_symbol -> (s, Extend.norec, a) Extend.symbol = +let rec untype_user_symbol : type s a b c. (a, b, c) Extend.ty_user_symbol -> (s, Gramlib.Grammar.norec, a) Pcoq.Symbol.t = let open Extend in function -| TUlist1 l -> Alist1 (untype_user_symbol l) -| TUlist1sep (l, s) -> Alist1sep (untype_user_symbol l, Atoken (CLexer.terminal s)) -| TUlist0 l -> Alist0 (untype_user_symbol l) -| TUlist0sep (l, s) -> Alist0sep (untype_user_symbol l, Atoken (CLexer.terminal s)) -| TUopt o -> Aopt (untype_user_symbol o) -| TUentry a -> Aentry (Pcoq.genarg_grammar (Genarg.ExtraArg a)) -| TUentryl (a, i) -> Aentryl (Pcoq.genarg_grammar (Genarg.ExtraArg a), string_of_int i) + | TUlist1 l -> Pcoq.Symbol.list1 (untype_user_symbol l) + | TUlist1sep (l, s) -> Pcoq.Symbol.list1sep (untype_user_symbol l) (Pcoq.Symbol.token (CLexer.terminal s)) false + | TUlist0 l -> Pcoq.Symbol.list0 (untype_user_symbol l) + | TUlist0sep (l, s) -> Pcoq.Symbol.list0sep (untype_user_symbol l) (Pcoq.Symbol.token (CLexer.terminal s)) false + | TUopt o -> Pcoq.Symbol.opt (untype_user_symbol o) + | TUentry a -> Pcoq.Symbol.nterm (Pcoq.genarg_grammar (Genarg.ExtraArg a)) + | TUentryl (a, i) -> Pcoq.Symbol.nterml (Pcoq.genarg_grammar (Genarg.ExtraArg a)) (string_of_int i) let rec untype_grammar : type r s. (r, s) ty_sig -> 'a Egramml.grammar_prod_item list = function | TyNil -> [] @@ -229,7 +229,7 @@ let vernac_extend ~command ?classifier ?entry ext = type 'a argument_rule = | Arg_alias of 'a Pcoq.Entry.t -| Arg_rules of 'a Extend.production_rule list +| Arg_rules of 'a Pcoq.Production.t list type 'a vernac_argument = { arg_printer : Environ.env -> Evd.evar_map -> 'a -> Pp.t; @@ -244,7 +244,7 @@ let vernac_argument_extend ~name arg = e | Arg_rules rules -> let e = Pcoq.create_generic_entry Pcoq.utactic name (Genarg.rawwit wit) in - let () = Pcoq.grammar_extend e (None, [(None, None, rules)]) in + let () = Pcoq.grammar_extend e {Pcoq.pos=None; data=[(None, None, rules)]} in e in let pr = arg.arg_printer in diff --git a/vernac/vernacextend.mli b/vernac/vernacextend.mli index 90c00415d4..0d0ebc1086 100644 --- a/vernac/vernacextend.mli +++ b/vernac/vernacextend.mli @@ -111,7 +111,7 @@ type 'a argument_rule = | Arg_alias of 'a Pcoq.Entry.t (** This is used because CAMLP5 parser can be dumb about rule factorization, which sometimes requires two entries to be the same. *) -| Arg_rules of 'a Extend.production_rule list +| Arg_rules of 'a Pcoq.Production.t list (** There is a discrepancy here as we use directly extension rules and thus entries instead of ty_user_symbol and thus arguments as roots. *) |